Test2-0.000025000755001750001750 012654206301 13261 5ustar00exodistexodist000000000000README100644001750001750 1001212654206301 14234 0ustar00exodistexodist000000000000Test2-0.000025NAME Test2 - Framework for writing test tools that all work together. EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. DESCRIPTION Test2 is a new testing framework produced by forking Test::Builder, completely refactoring it, adding many new features and capabilities. GETTING STARTED If you are interested in writing tests using new tools then you should look at NOT YET DETERMINED. If you are interested in writing new tools you should take a look at Test2::API first. NAMESPACE LAYOUT 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 acceptible for third party distributions to create new formatters under this namespace. Test2::Event:: Events live under this namespace. It is considered acceptible 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 extentions and frameworks. Tools, Plugins, etc should not go directly into this namespace. However extentions 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. SOURCE The source code repository for Test2 can be found at http://github.com/Test-More/Test2/. MAINTAINERS Chad Granum AUTHORS Chad Granum COPYRIGHT Copyright 2015 Chad Granum . This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://dev.perl.org/licenses/ LICENSE100644001750001750 4365212654206301 14401 0ustar00exodistexodist000000000000Test2-0.000025This software is copyright (c) 2016 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) 2016 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 Artistic License 1.0 --- This software is Copyright (c) 2016 by Chad Granum. This is free software, licensed under: The 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. - "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 ftp.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) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting 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. 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 whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Changes100644001750001750 2573412654206301 14670 0ustar00exodistexodist000000000000Test2-0.0000250.000025 2016-02-02 12:08:32-08:00 America/Los_Angeles - Fix occasional warning in cleanup 0.000024 2016-01-29 21:16:56-08:00 America/Los_Angeles - Add no_context() (needed for external tool) 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 0.000022 2016-01-18 11:58:40-08:00 America/Los_Angeles - Fix test that broke in the last release (oops) 0.000021 2016-01-18 10:54:54-08:00 America/Los_Angeles - Fix bug where default diagnostics were not shown for subtests. 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 0.000019 2016-01-12 16:08:11-08:00 America/Los_Angeles - Make third-party meta-data interface consistent. 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 0.000017 2016-01-11 16:33:55-08:00 America/Los_Angeles - Fix $! squashing 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 0.000015 2016-01-07 19:26:58-08:00 America/Los_Angeles - Make it possible to use a custom new() with HashBase 0.000014 2016-01-07 07:31:23-08:00 America/Los_Angeles - Silence a warning in older perls (warning breaks Test-Simple tests) 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 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 0.000011 2015-12-28 13:09:38-08:00 America/Los_Angeles - Fix TAP output to match what Test::More produced 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. 0.000009 2015-12-21 10:13:18-08:00 America/Los_Angeles - Fix typo in Test2::Event 0.000008 2015-12-21 09:54:58-08:00 America/Los_Angeles - Bring back 'release' export of Test2. 0.000007 2015-12-20 12:09:04-08:00 America/Los_Angeles - Fix version number string - Fix typo 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 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 (backwords 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 MANIFEST100644001750001750 350712654206301 14500 0ustar00exodistexodist000000000000Test2-0.000025# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.042. Changes Examples/tools.pl Examples/tools.t LICENSE MANIFEST META.json META.yml Makefile.PL README README.md cpanfile lib/Test2.pm lib/Test2/API.pm lib/Test2/API/Context.pm lib/Test2/API/Instance.pm lib/Test2/API/Stack.pm lib/Test2/Event.pm lib/Test2/Event/Bail.pm lib/Test2/Event/Diag.pm lib/Test2/Event/Exception.pm lib/Test2/Event/Note.pm lib/Test2/Event/Ok.pm lib/Test2/Event/Plan.pm lib/Test2/Event/Skip.pm lib/Test2/Event/Subtest.pm lib/Test2/Event/Waiting.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/Util.pm lib/Test2/Util/ExternalMeta.pm lib/Test2/Util/HashBase.pm lib/Test2/Util/Trace.pm t/00-report.t t/acceptance/try_it_done_testing.t t/acceptance/try_it_fork.t t/acceptance/try_it_no_plan.t t/acceptance/try_it_plan.t t/acceptance/try_it_skip.t t/acceptance/try_it_threads.t t/acceptance/try_it_todo.t t/behavior/Taint.t t/behavior/err_var.t t/behavior/nested_context_exception.t t/legacy/TAP.t t/modules/API.t t/modules/API/Context.t t/modules/API/Instance.t t/modules/API/Stack.t t/modules/Event.t t/modules/Event/Bail.t t/modules/Event/Diag.t t/modules/Event/Exception.t t/modules/Event/Note.t t/modules/Event/Ok.t t/modules/Event/Plan.t t/modules/Event/Skip.t t/modules/Event/Subtest.t t/modules/Event/Waiting.t t/modules/Formatter/TAP.t t/modules/Hub.t t/modules/Hub/Interceptor.t t/modules/Hub/Interceptor/Terminator.t t/modules/Hub/Subtest.t t/modules/IPC.t t/modules/IPC/Driver.t t/modules/IPC/Driver/Files.t t/modules/Util.t t/modules/Util/ExternalMeta.t t/modules/Util/HashBase.t t/modules/Util/Trace.t t/regression/ipc_files_abort_exit.t t/tools.pl t/tools.t cpanfile100644001750001750 54212654206301 15027 0ustar00exodistexodist000000000000Test2-0.000025requires "Carp" => "0"; requires "File::Spec" => "0"; requires "File::Temp" => "0"; requires "PerlIO" => "0"; requires "Scalar::Util" => "0"; requires "Storable" => "0"; requires "perl" => "5.008001"; requires "utf8" => "0"; on 'configure' => sub { requires "ExtUtils::MakeMaker" => "0"; }; on 'develop' => sub { requires "Test::Pod" => "1.41"; }; META.yml100644001750001750 124312654206301 14613 0ustar00exodistexodist000000000000Test2-0.000025--- abstract: 'Framework for writing test tools that all work together.' author: - 'Chad Granum ' build_requires: {} configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Dist::Zilla version 5.042, CPAN::Meta::Converter version 2.150001' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Test2 requires: Carp: '0' File::Spec: '0' File::Temp: '0' PerlIO: '0' Scalar::Util: '0' Storable: '0' perl: '5.008001' utf8: '0' resources: bugtracker: http://github.com/Test-More/Test2/issues repository: http://github.com/Test-More/Test2/ version: '0.000025' README.md100644001750001750 1035712654206301 14647 0ustar00exodistexodist000000000000Test2-0.000025# NAME Test2 - Framework for writing test tools that all work together. # EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. # DESCRIPTION Test2 is a new testing framework produced by forking [Test::Builder](https://metacpan.org/pod/Test::Builder), completely refactoring it, adding many new features and capabilities. # GETTING STARTED If you are interested in writing tests using new tools then you should look at **NOT YET DETERMINED**. If you are interested in writing new tools you should take a look at [Test2::API](https://metacpan.org/pod/Test2::API) first. # NAMESPACE LAYOUT ## 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::Formatter::TAP) is the only formatter currently. It is acceptible for third party distributions to create new formatters under this namespace. ## Test2::Event:: Events live under this namespace. It is considered acceptible 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 extentions and frameworks. Tools, Plugins, etc should not go directly into this namespace. However extentions 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::API) - Primary API functions. [Test2::API::Context](https://metacpan.org/pod/Test2::API::Context) - Detailed documentation of the context object. [Test2::IPC](https://metacpan.org/pod/Test2::IPC) - The IPC system used for threading/fork support. [Test2::Formatter](https://metacpan.org/pod/Test2::Formatter) - Formatters such as TAP live here. [Test2::Event](https://metacpan.org/pod/Test2::Event) - Events live in this namespace. [Test2::Hub](https://metacpan.org/pod/Test2::Hub) - All events eventually funnel through a hub. Custom hubs are how `intercept()` and `run_subtest()` are implemented. # SOURCE The source code repository for Test2 can be found at `http://github.com/Test-More/Test2/`. # MAINTAINERS - Chad Granum <exodist@cpan.org> # AUTHORS - Chad Granum <exodist@cpan.org> # COPYRIGHT Copyright 2015 Chad Granum <exodist7@gmail.com>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See `http://dev.perl.org/licenses/` t000755001750001750 012654206301 13445 5ustar00exodistexodist000000000000Test2-0.000025tools.t100644001750001750 1146712654206301 15163 0ustar00exodistexodist000000000000Test2-0.000025/tuse 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 $main_events = intercept { plan 8; ok(0, "'ok' Test"); is("foo", "bar", "'is' test"); isnt("foo", "foo", "'isnt' test"); like("foo", qr/a/, "'like' test"); unlike("foo", qr/o/, "'unlike' test"); is_deeply( { a => 1, b => 2, c => {}}, { a => 1, b => 2, c => []}, "'is_deeply' test" ); }; my $other_events = intercept { diag("Testing Diag"); note("Testing Note"); }; my ($plan, $ok, $is, $isnt, $like, $unlike, $is_deeply) = grep {!$_->isa('Test2::Event::Diag')} @$main_events; my ($diag, $note) = @$other_events; ok($plan->isa('Test2::Event::Plan'), "got plan"); is($plan->max, 8, "planned for 8 oks"); ok($ok->isa('Test2::Event::Ok'), "got 'ok' result"); is($ok->pass, 0, "'ok' test failed"); ok($is->isa('Test2::Event::Ok'), "got 'is' result"); is($is->pass, 0, "'is' test failed"); ok($isnt->isa('Test2::Event::Ok'), "got 'isnt' result"); is($isnt->pass, 0, "'isnt' test failed"); ok($like->isa('Test2::Event::Ok'), "got 'like' result"); is($like->pass, 0, "'like' test failed"); ok($unlike->isa('Test2::Event::Ok'), "got 'unlike' result"); is($unlike->pass, 0, "'unlike' test failed"); ok($is_deeply->isa('Test2::Event::Ok'), "got 'is_deeply' result"); is($is_deeply->pass, 0, "'is_deeply' test failed"); ok($diag->isa('Test2::Event::Diag'), "got 'diag' result"); is($diag->message, "Testing Diag", "got diag message"); ok($note->isa('Test2::Event::Note'), "got 'note' result"); is($note->message, "Testing Note", "got note message"); my $events = intercept { skip_all 'because'; ok(0, "should not see me"); die "should not happen"; }; is(@$events, 1, "1 event"); ok($events->[0]->isa('Test2::Event::Plan'), "got plan"); is($events->[0]->directive, 'SKIP', "plan is skip"); is($events->[0]->reason, 'because', "skip reason"); $events = intercept { is(undef, ""); is("", undef); isnt(undef, undef); like(undef, qr//); unlike(undef, qr//); }; @$events = grep {!$_->isa('Test2::Event::Diag')} @$events; is(@$events, 5, "5 events"); ok(!$_->pass, "undef test - should not pass") for @$events; sub tool { context() }; my %params; my $ctx = context(level => -1); my $ictx; $events = intercept { %params = @_; $ictx = tool(); $ictx->ok(1, 'pass'); $ictx->ok(0, 'fail'); my $trace = Test2::Util::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__], ); $ictx->hub->finalize($trace, 1); }; @$events = grep {!$_->isa('Test2::Event::Diag')} @$events; is_deeply( \%params, { context => { %$ctx, _is_canon => undef, _is_spawn => undef, _aborted => undef }, hub => $ictx->hub, }, "Passed in some useful params" ); ok($ctx != $ictx, "Different context inside intercept"); is(@$events, 3, "got 3 events"); $ctx->release; $ictx->release; # Test that a bail-out in an intercept does not exit. $events = intercept { $ictx = tool(); $ictx->bail("The world ends"); $ictx->ok(0, "Should not see this"); }; is(@$events, 1, "got 1 event"); ok($events->[0]->isa('Test2::Event::Bail'), "got the bail"); $events = intercept { $ictx = tool(); }; $ictx->release; like( exception { intercept { die 'foo' } }, qr/foo/, "Exception was propogated" ); $events = intercept { test2_stack()->top->set_no_ending(0); ok(1); }; is(@$events, 2, "2 events"); ok($events->[0]->isa('Test2::Event::Ok'), "got ok"); ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called"); $events = intercept { test2_stack()->top->set_no_ending(0); ok(1); done_testing; }; is(@$events, 2, "2 events"); ok($events->[0]->isa('Test2::Event::Ok'), "got ok"); ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called (only 1 plan)"); done_testing; META.json100644001750001750 232712654206301 14767 0ustar00exodistexodist000000000000Test2-0.000025{ "abstract" : "Framework for writing test tools that all work together.", "author" : [ "Chad Granum " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 5.042, CPAN::Meta::Converter version 2.150001", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Test2", "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Test::Pod" : "1.41" } }, "runtime" : { "requires" : { "Carp" : "0", "File::Spec" : "0", "File::Temp" : "0", "PerlIO" : "0", "Scalar::Util" : "0", "Storable" : "0", "perl" : "5.008001", "utf8" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://github.com/Test-More/Test2/issues" }, "repository" : { "type" : "git", "url" : "http://github.com/Test-More/Test2/" } }, "version" : "0.000025" } tools.pl100644001750001750 1100312654206301 15315 0ustar00exodistexodist000000000000Test2-0.000025/tuse Scalar::Util qw/blessed/; use Test2::Util qw/try/; use Test2::API 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 is_deeply($$;$@) { my ($got, $want, $name, @diag) = @_; my $ctx = context(); no warnings 'once'; require Data::Dumper; local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Deparse = 1; local $Data::Dumper::Freezer = 'XXX'; local *UNIVERSAL::XXX = sub { my ($thing) = @_; if (ref($thing)) { $thing = {%$thing} if "$thing" =~ m/=HASH/; $thing = [@$thing] if "$thing" =~ m/=ARRAY/; $thing = \"$$thing" if "$thing" =~ m/=SCALAR/; } $_[0] = $thing; }; my $g = Data::Dumper::Dumper($got); my $w = Data::Dumper::Dumper($want); my $bool = $g eq $w; my $diff; # unless ($bool) { # use File::Temp; # my ($gFH, $fileg) = File::Temp::tempfile(); # my ($wFH, $filew) = File::Temp::tempfile(); # print $gFH $g; # print $wFH $w; # close($gFH) || die $!; # close($wFH) || die $!; # my $cmd = qq{git diff --color=always "$fileg" "$filew"}; # $diff = eval { `$cmd` }; # } $ctx->ok($bool, $name, [$diff ? $diff : ($g, $w), @diag]); $ctx->release; return $bool; } sub diag { my $ctx = context(); $ctx->diag( join '', @_ ); $ctx->release; } sub note { my $ctx = context(); $ctx->note( join '', @_ ); $ctx->release; } sub skip_all { my ($reason) = @_; my $ctx = context(); $ctx->plan(0, SKIP => $reason); $ctx->release if $ctx; } sub plan { my ($max) = @_; my $ctx = context(); $ctx->plan($max); $ctx->release; } sub done_testing { my $ctx = context(); $ctx->done_testing; $ctx->release; } sub warnings(&) { my $code = shift; my @warnings; local $SIG{__WARN__} = sub { push @warnings => @_ }; $code->(); return \@warnings; } sub exception(&) { my $code = shift; local ($@, $!, $SIG{__DIE__}); my $ok = eval { $code->(); 1 }; my $error = $@ || 'SQUASHED ERROR'; return $ok ? undef : $error; } sub tests { my ($name, $code) = @_; my $ctx = context(); before_each() if __PACKAGE__->can('before_each'); my $bool = run_subtest($name, $code, 1); $ctx->release; return $bool; } 1; Makefile.PL100644001750001750 266312654206301 15323 0ustar00exodistexodist000000000000Test2-0.000025# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.042. use strict; use warnings; use 5.008001; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( "ABSTRACT" => "Framework for writing test tools that all work together.", "AUTHOR" => "Chad Granum ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "Test2", "LICENSE" => "perl", "MIN_PERL_VERSION" => "5.008001", "NAME" => "Test2", "PREREQ_PM" => { "Carp" => 0, "File::Spec" => 0, "File::Temp" => 0, "PerlIO" => 0, "Scalar::Util" => 0, "Storable" => 0, "utf8" => 0 }, "VERSION" => "0.000025", "test" => { "TESTS" => "t/*.t t/acceptance/*.t t/behavior/*.t t/legacy/*.t t/modules/*.t t/modules/API/*.t t/modules/Event/*.t t/modules/Formatter/*.t t/modules/Hub/*.t t/modules/Hub/Interceptor/*.t t/modules/IPC/*.t t/modules/IPC/Driver/*.t t/modules/Util/*.t t/regression/*.t" } ); my %FallbackPrereqs = ( "Carp" => 0, "File::Spec" => 0, "File::Temp" => 0, "PerlIO" => 0, "Scalar::Util" => 0, "Storable" => 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) }; WriteMakefile(%WriteMakefileArgs); lib000755001750001750 012654206301 13750 5ustar00exodistexodist000000000000Test2-0.000025Test2.pm100644001750001750 1020412654206301 15464 0ustar00exodistexodist000000000000Test2-0.000025/libpackage Test2; use strict; use warnings; our $VERSION = '0.000025'; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2 - Framework for writing test tools that all work together. =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 DESCRIPTION Test2 is a new testing framework produced by forking L, completely refactoring it, adding many new features and capabilities. =head1 GETTING STARTED If you are interested in writing tests using new tools then you should look at L. If you are interested in writing new tools you should take a look at L first. =head1 NAMESPACE LAYOUT =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 acceptible for third party distributions to create new formatters under this namespace. =head2 Test2::Event:: Events live under this namespace. It is considered acceptible 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 extentions and frameworks. Tools, Plugins, etc should not go directly into this namespace. However extentions 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 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 2015 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 00-report.t100644001750001750 144412654206301 15525 0ustar00exodistexodist000000000000Test2-0.000025/tuse strict; use warnings; BEGIN { require "t/tools.pl" }; use Data::Dumper; use Test2::Util qw/CAN_FORK CAN_REALLY_FORK CAN_THREAD/; diag "\nDIAGNOSTICS INFO IN CASE OF FAILURE:\n"; diag "\nPerl: $]"; diag "\nCAPABILITIES:"; diag 'CAN_FORK ' . (CAN_FORK ? 'Yes' : 'No'); diag 'CAN_REALLY_FORK ' . (CAN_REALLY_FORK ? 'Yes' : 'No'); diag 'CAN_THREAD ' . (CAN_THREAD ? 'Yes' : 'No'); diag "\nDEPENDENCIES:"; my @depends = sort qw{ Carp File::Spec File::Temp PerlIO Scalar::Util Storable overload utf8 threads }; my %deps; my $len = 0; for my $dep (@depends) { my $l = length($dep); $len = $l if $l > $len; $deps{$dep} = eval "require $dep; $dep->VERSION" || "N/A"; } diag sprintf("%-${len}s %s", $_, $deps{$_}) for @depends; ok(1); done_testing; legacy000755001750001750 012654206301 14711 5ustar00exodistexodist000000000000Test2-0.000025/tTAP.t100644001750001750 614712654206301 15672 0ustar00exodistexodist000000000000Test2-0.000025/t/legacyuse strict; use warnings; BEGIN { require "t/tools.pl" }; ######################### # # 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/; sub capture(&) { my $code = shift; my ($err, $out) = ("", ""); my $handles = test2_stack->top->format->handles; my ($ok, $e); { my ($out_fh, $err_fh); ($ok, $e) = try { open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!"; open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!"; test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]); $code->(); }; } test2_stack->top->format->set_handles($handles); die $e unless $ok; $err =~ s/ $/_/mg; $out =~ s/ $/_/mg; return { STDOUT => $out, STDERR => $err, }; } # The tools in tools.pl 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; $name && ( (index($name, "#" ) >= 0 && $name =~ s|#|\\#|g), (index($name, "\n") >= 0 && $name =~ s{\n}{\n# }sg) ); my $ok = bless { pass => $bool, name => $name, effective_pass => 1, trace => $ctx->trace->snapshot, }, 'Test2::Event::Ok'; # Do not call init $ctx->hub->send($ok); $ctx->release; return $bool; } # Test::More actually does a bit more, but for this test we just want to see # what happens when message is a specific string, or undef. sub tm_diag { my $ctx = context(); $ctx->diag(@_); $ctx->release; } sub tm_note { my $ctx = context(); $ctx->note(@_); $ctx->release; } # Ensure the top hub is generated test2_stack->top; my $temp_hub = test2_stack->new_hub(); my $diag = capture { tm_diag(undef); tm_diag(""); tm_diag(" "); tm_diag("A"); tm_diag("\n"); tm_diag("\nB"); tm_diag("C\n"); tm_diag("\nD\n"); tm_diag("E\n\n"); }; my $note = capture { tm_note(undef); tm_note(""); tm_note(" "); tm_note("A"); tm_note("\n"); tm_note("\nB"); tm_note("C\n"); tm_note("\nD\n"); tm_note("E\n\n"); }; my $ok = capture { tm_ok(1); tm_ok(1, ""); tm_ok(1, " "); tm_ok(1, "A"); tm_ok(1, "\n"); tm_ok(1, "\nB"); tm_ok(1, "C\n"); tm_ok(1, "\nD\n"); tm_ok(1, "E\n\n"); }; test2_stack->pop($temp_hub); is($diag->{STDOUT}, "", "STDOUT is empty for diag"); is($diag->{STDERR}, <{STDERR}, "", "STDERR for note is empty"); is($note->{STDOUT}, <{STDERR}, "", "STDERR for ok is empty"); is($ok->{STDOUT}, < $e; } } { package My::Event; use base 'Test2::Event'; use Test2::Util::HashBase qw{msg}; } tests basic => sub { my $hub = Test2::Hub->new( formatter => My::Formatter->new, ); my $send_event = sub { my ($msg) = @_; my $e = My::Event->new(msg => $msg, trace => 'fake'); $hub->send($e); }; ok(my $e1 = $send_event->('foo'), "Created event"); ok(my $e2 = $send_event->('bar'), "Created event"); ok(my $e3 = $send_event->('baz'), "Created event"); my $old = $hub->format(My::Formatter->new); ok($old->isa('My::Formatter'), "old formatter"); is_deeply( $old, [$e1, $e2, $e3], "Formatter got all events" ); }; tests follow_ups => sub { my $hub = Test2::Hub->new; $hub->set_count(1); my $trace = Test2::Util::Trace->new( frame => [__PACKAGE__, __FILE__, __LINE__], ); my $ran = 0; $hub->follow_up(sub { my ($d, $h) = @_; is_deeply($d, $trace, "Got trace"); is_deeply($h, $hub, "Got hub"); ok(!$hub->ended, "Hub state has not ended yet"); $ran++; }); like( exception { $hub->follow_up('xxx') }, qr/follow_up only takes coderefs for arguments, got 'xxx'/, "follow_up takes a coderef" ); $hub->finalize($trace); is($ran, 1, "ran once"); is_deeply( $hub->ended, $trace->frame, "Ended at the expected place." ); eval { $hub->finalize($trace) }; is($ran, 1, "ran once"); $hub = undef; }; tests IPC => sub { my ($driver) = test2_ipc_drivers(); is($driver, 'Test2::IPC::Driver::Files', "Default Driver"); my $ipc = $driver->new; my $hub = Test2::Hub->new( formatter => My::Formatter->new, ipc => $ipc, ); my $build_event = sub { my ($msg) = @_; return My::Event->new(msg => $msg, trace => 'fake'); }; my $e1 = $build_event->('foo'); my $e2 = $build_event->('bar'); my $e3 = $build_event->('baz'); my $do_send = sub { $hub->send($e1); $hub->send($e2); $hub->send($e3); }; my $do_check = sub { my $name = shift; my $old = $hub->format(My::Formatter->new); ok($old->isa('My::Formatter'), "old formatter"); is_deeply( $old, [$e1, $e2, $e3], "Formatter got all events ($name)" ); }; if (CAN_REALLY_FORK) { my $pid = fork(); die "Could not fork!" unless defined $pid; if ($pid) { is(waitpid($pid, 0), $pid, "waited properly"); ok(!$?, "child exited with success"); $hub->cull(); $do_check->('Fork'); } else { $do_send->(); exit 0; } } if (CAN_THREAD && $] ge '5.010') { require threads; my $thr = threads->new(sub { $do_send->() }); $thr->join; $hub->cull(); $do_check->('Threads'); } $do_send->(); $hub->cull(); $do_check->('no IPC'); }; tests listen => sub { my $hub = Test2::Hub->new(); my @events; my @counts; my $it = $hub->listen(sub { my ($h, $e, $count) = @_; is_deeply($h, $hub, "got hub"); push @events => $e; push @counts => $count; }); my $second; my $it2 = $hub->listen(sub { $second++ }); my $ok1 = Test2::Event::Ok->new( pass => 1, name => 'foo', trace => Test2::Util::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok2 = Test2::Event::Ok->new( pass => 0, name => 'bar', trace => Test2::Util::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok3 = Test2::Event::Ok->new( pass => 1, name => 'baz', trace => Test2::Util::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); $hub->send($ok1); $hub->send($ok2); $hub->unlisten($it); $hub->send($ok3); is_deeply(\@counts, [1, 2], "Got counts"); is_deeply(\@events, [$ok1, $ok2], "got events"); is($second, 3, "got all events in listener that was not removed"); like( exception { $hub->listen('xxx') }, qr/listen only takes coderefs for arguments, got 'xxx'/, "listen takes a coderef" ); }; tests metadata => sub { my $hub = Test2::Hub->new(); my $default = { foo => 1 }; my $meta = $hub->meta('Foo', $default); is_deeply($meta, $default, "Set Meta"); $meta = $hub->meta('Foo', {}); is_deeply($meta, $default, "Same Meta"); $hub->delete_meta('Foo'); is($hub->meta('Foo'), undef, "No Meta"); $hub->meta('Foo', {})->{xxx} = 1; is($hub->meta('Foo')->{xxx}, 1, "Vivified meta and set it"); like( exception { $hub->meta(undef) }, qr/Invalid META key: undef, keys must be true, and may not be references/, "Cannot use undef as a meta key" ); like( exception { $hub->meta(0) }, qr/Invalid META key: '0', keys must be true, and may not be references/, "Cannot use 0 as a meta key" ); like( exception { $hub->delete_meta(undef) }, qr/Invalid META key: undef, keys must be true, and may not be references/, "Cannot use undef as a meta key" ); like( exception { $hub->delete_meta(0) }, qr/Invalid META key: '0', keys must be true, and may not be references/, "Cannot use 0 as a meta key" ); }; tests filter => sub { my $hub = Test2::Hub->new(); my @events; my $it = $hub->filter(sub { my ($h, $e) = @_; is($h, $hub, "got hub"); push @events => $e; return $e; }); my $count; my $it2 = $hub->filter(sub { $count++; $_[1] }); my $ok1 = Test2::Event::Ok->new( pass => 1, name => 'foo', trace => Test2::Util::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok2 = Test2::Event::Ok->new( pass => 0, name => 'bar', trace => Test2::Util::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok3 = Test2::Event::Ok->new( pass => 1, name => 'baz', trace => Test2::Util::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); $hub->send($ok1); $hub->send($ok2); $hub->unfilter($it); $hub->send($ok3); is_deeply(\@events, [$ok1, $ok2], "got events"); is($count, 3, "got all events, even after other filter was removed"); $hub = Test2::Hub->new(); @events = (); $hub->filter(sub { undef }); $hub->listen(sub { my ($hub, $e) = @_; push @events => $e; }); $hub->send($ok1); $hub->send($ok2); $hub->send($ok3); ok(!@events, "Blocked events"); like( exception { $hub->filter('xxx') }, qr/filter only takes coderefs for arguments, got 'xxx'/, "filter takes a coderef" ); }; tests pre_filter => sub { my $hub = Test2::Hub->new(); my @events; my $it = $hub->pre_filter(sub { my ($h, $e) = @_; is($h, $hub, "got hub"); push @events => $e; return $e; }); my $count; my $it2 = $hub->pre_filter(sub { $count++; $_[1] }); my $ok1 = Test2::Event::Ok->new( pass => 1, name => 'foo', trace => Test2::Util::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok2 = Test2::Event::Ok->new( pass => 0, name => 'bar', trace => Test2::Util::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); my $ok3 = Test2::Event::Ok->new( pass => 1, name => 'baz', trace => Test2::Util::Trace->new( frame => [ __PACKAGE__, __FILE__, __LINE__ ], ), ); $hub->send($ok1); $hub->send($ok2); $hub->pre_unfilter($it); $hub->send($ok3); is_deeply(\@events, [$ok1, $ok2], "got events"); is($count, 3, "got all events, even after other pre_filter was removed"); $hub = Test2::Hub->new(); @events = (); $hub->pre_filter(sub { undef }); $hub->listen(sub { my ($hub, $e) = @_; push @events => $e; }); $hub->send($ok1); $hub->send($ok2); $hub->send($ok3); ok(!@events, "Blocked events"); like( exception { $hub->pre_filter('xxx') }, qr/pre_filter only takes coderefs for arguments, got 'xxx'/, "pre_filter takes a coderef" ); }; tests state => sub { my $hub = Test2::Hub->new; is($hub->count, 0, "count starts at 0"); is($hub->failed, 0, "failed starts at 0"); is($hub->is_passing, 1, "start off passing"); is($hub->plan, undef, "no plan yet"); $hub->is_passing(0); is($hub->is_passing, 0, "Can Fail"); $hub->is_passing(1); is($hub->is_passing, 1, "Passes again"); $hub->set_count(1); is($hub->count, 1, "Added a passing result"); is($hub->failed, 0, "still no fails"); is($hub->is_passing, 1, "Still passing"); $hub->set_count(2); $hub->set_failed(1); is($hub->count, 2, "Added a result"); is($hub->failed, 1, "new failure"); is($hub->is_passing, 0, "Not passing"); $hub->is_passing(1); is($hub->is_passing, 0, "is_passing always false after a failure"); $hub->set_failed(0); $hub->is_passing(1); is($hub->is_passing, 1, "Passes again"); $hub->set_failed(1); is($hub->count, 2, "No new result"); is($hub->failed, 1, "new failure"); is($hub->is_passing, 0, "Not passing"); ok(!eval { $hub->plan('foo'); 1 }, "Could not set plan to 'foo'"); like($@, qr/'foo' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'/, "Got expected error"); ok($hub->plan(5), "Can set plan to integer"); is($hub->plan, 5, "Set the plan to an integer"); $hub->set__plan(undef); ok($hub->plan('NO PLAN'), "Can set plan to 'NO PLAN'"); is($hub->plan, 'NO PLAN', "Set the plan to 'NO PLAN'"); $hub->set__plan(undef); ok($hub->plan('SKIP'), "Can set plan to 'SKIP'"); is($hub->plan, 'SKIP', "Set the plan to 'SKIP'"); ok(!eval { $hub->plan(5); 1 }, "Cannot change plan"); like($@, qr/You cannot change the plan/, "Got error"); my $trace = Test2::Util::Trace->new(frame => ['Foo::Bar', 'foo.t', 42, 'blah']); $hub->finalize($trace); my $ok = eval { $hub->finalize($trace) }; my $err = $@; ok(!$ok, "died"); is($err, <<" EOT", "Got expected error"); Test already ended! First End: foo.t line 42 Second End: foo.t line 42 EOT $hub = Test2::Hub->new; $hub->plan(5); $hub->set_count(5); $hub->set_failed(1); $hub->set_ended($trace); $hub->set_bailed_out("foo"); $hub->set_skip_reason('xxx'); ok(!$hub->is_passing, "not passing"); $hub->reset_state; ok(!$hub->plan, "no plan"); is($hub->count, 0, "count reset to 0"); is($hub->failed, 0, "reset failures"); ok(!$hub->ended, "not ended"); ok(!$hub->bailed_out, "did not bail out"); ok(!$hub->skip_reason, "no skip reason"); }; done_testing; API.t100644001750001750 2007412654206301 16076 0ustar00exodistexodist000000000000Test2-0.000025/t/modulesuse strict; use warnings; use Test2::API; my ($LOADED, $INIT); BEGIN { $INIT = Test2::API::test2_init_done; $LOADED = Test2::API::test2_load_done; }; use Test2::IPC; BEGIN { require "t/tools.pl" }; 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_add_callback_context_init test2_add_callback_context_release test2_add_callback_exit test2_add_callback_post_load test2_list_context_init_callbacks test2_list_context_release_callbacks test2_list_exit_callbacks test2_list_post_load_callbacks test2_ipc test2_ipc_drivers test2_ipc_add_driver test2_ipc_polling test2_ipc_disable_polling test2_ipc_enable_polling test2_formatter test2_formatters test2_formatter_add test2_formatter_set }; ok(!$LOADED, "Was not load_done right away"); ok(!$INIT, "Init was not done right away"); ok(Test2::API::test2_load_done, "We loaded it"); # Note: This is a check that stuff happens in an END block. { { package FOLLOW; sub DESTROY { return if $_[0]->{fixed}; print "not ok - Did not run end ($_[0]->{name})!"; $? = 255; exit 255; } } our $kill1 = bless {fixed => 0, name => "Custom Hook"}, 'FOLLOW'; Test2::API::test2_add_callback_exit( sub { print "# Running END hook\n"; $kill1->{fixed} = 1; } ); our $kill2 = bless {fixed => 0, name => "set exit"}, 'FOLLOW'; my $old = Test2::API::Instance->can('set_exit'); no warnings 'redefine'; *Test2::API::Instance::set_exit = sub { $kill2->{fixed} = 1; print "# Running set_exit\n"; $old->(@_); }; } ok($CLASS->can('test2_init_done')->(), "init is done."); ok($CLASS->can('test2_load_done')->(), "Test2 is finished loading"); is($CLASS->can('test2_pid')->(), $$, "got pid"); is($CLASS->can('test2_tid')->(), get_tid(), "got tid"); ok($CLASS->can('test2_stack')->(), 'got stack'); is($CLASS->can('test2_stack')->(), $CLASS->can('test2_stack')->(), "always get the same stack"); ok($CLASS->can('test2_ipc')->(), 'got ipc'); is($CLASS->can('test2_ipc')->(), $CLASS->can('test2_ipc')->(), "always get the same IPC"); is_deeply([$CLASS->can('test2_ipc_drivers')->()], [qw/Test2::IPC::Driver::Files/], "Got driver list"); # Verify it reports to the correct file/line, there was some trouble with this... my $file = __FILE__; my $line = __LINE__ + 1; my $warnings = warnings { $CLASS->can('test2_ipc_add_driver')->('fake') }; like( $warnings->[0], qr{^IPC driver fake loaded too late to be used as the global ipc driver at \Q$file\E line $line}, "got warning about adding driver too late" ); is_deeply([$CLASS->can('test2_ipc_drivers')->()], [qw/fake Test2::IPC::Driver::Files/], "Got updated list"); ok($CLASS->can('test2_ipc_polling')->(), "Polling is on"); $CLASS->can('test2_ipc_disable_polling')->(); ok(!$CLASS->can('test2_ipc_polling')->(), "Polling is off"); $CLASS->can('test2_ipc_enable_polling')->(); ok($CLASS->can('test2_ipc_polling')->(), "Polling is on"); ok($CLASS->can('test2_formatter')->(), "Got a formatter"); is($CLASS->can('test2_formatter')->(), $CLASS->can('test2_formatter')->(), "always get the same Formatter (class name)"); my $ran = 0; $CLASS->can('test2_add_callback_post_load')->(sub { $ran++ }); is($ran, 1, "ran the post-load"); like( exception { $CLASS->can('test2_formatter_set')->() }, qr/No formatter specified/, "formatter_set requires an argument" ); like( exception { $CLASS->can('test2_formatter_set')->('fake') }, qr/Global Formatter already set/, "formatter_set doesn't work after initialization", ); ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set"); $CLASS->can('test2_no_wait')->(1); ok($CLASS->can('test2_no_wait')->(), "no_wait is set"); $CLASS->can('test2_no_wait')->(undef); ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set"); my $pctx; sub tool_a($;$) { Test2::API::context_do { my $ctx = shift; my ($bool, $name) = @_; $pctx = wantarray; die "xyz" unless $bool; $ctx->ok($bool, $name); return unless defined $pctx; return (1, 2) if $pctx; return 'a'; } @_; } $pctx = 'x'; tool_a(1, "void context test"); ok(!defined($pctx), "void context"); my $x = tool_a(1, "scalar context test"); ok(defined($pctx) && $pctx == 0, "scalar context"); is($x, 'a', "got scalar return"); my @x = tool_a(1, "array context test"); ok($pctx, "array context"); is_deeply(\@x, [1, 2], "Got array return"); like( exception { tool_a(0) }, qr/^xyz/, "got exception" ); sub { my $outer = context(); sub { my $middle = context(); is($outer->trace, $middle->trace, "got the same context before calling no_context"); Test2::API::no_context { my $inner = context(); ok($inner->trace != $outer->trace, "Got a different context inside of no_context()"); $inner->release; }; $middle->release; }->(); $outer->release; }->(); sub { my $outer = context(); sub { my $middle = context(); is($outer->trace, $middle->trace, "got the same context before calling no_context"); Test2::API::no_context { my $inner = context(); ok($inner->trace != $outer->trace, "Got a different context inside of no_context({}, hid)"); $inner->release; } $outer->hub->hid; $middle->release; }->(); $outer->release; }->(); sub { my @warnings; my $outer = context(); sub { my $middle = context(); is($outer->trace, $middle->trace, "got the same context before calling no_context"); local $SIG{__WARN__} = sub { push @warnings => @_ }; Test2::API::no_context { my $inner = context(); ok($inner->trace != $outer->trace, "Got a different context inside of no_context({}, hid)"); } $outer->hub->hid; $middle->release; }->(); $outer->release; is(@warnings, 1, "1 warning"); like( $warnings[0], qr/A context appears to have been destroyed without first calling release/, "Got warning about unreleased context" ); }->(); my $sub = sub { }; Test2::API::test2_add_callback_context_aquire($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_aquire_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_aquire($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_aquire_callbacks()), 2, "got the two instances of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_context_init_callbacks()), 2, "got the two instances of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_context_release_callbacks()), 2, "got the two instances of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_exit_callbacks()), 2, "got the two instances of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_post_load_callbacks()), 2, "got the two instances of the hook"); done_testing; IPC.t100644001750001750 47412654206301 16042 0ustar00exodistexodist000000000000Test2-0.000025/t/modulesuse strict; use warnings; use Test2::IPC qw/cull/; use Test2::API qw/context test2_ipc_drivers test2_ipc/; BEGIN { require "t/tools.pl" }; test2_ipc(); is_deeply( [test2_ipc_drivers()], ['Test2::IPC::Driver::Files'], "Default driver" ); ok(__PACKAGE__->can('cull'), "Imported cull"); done_testing; Test2000755001750001750 012654206301 14751 5ustar00exodistexodist000000000000Test2-0.000025/libAPI.pm100644001750001750 7622312654206301 16112 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2package Test2::API; use strict; use warnings; my $INST; use Test2::API::Instance(\$INST); # Set the exit status END { $INST->set_exit() } use Test2::Util::Trace(); use Test2::Hub::Subtest(); use Test2::Hub::Interceptor(); use Test2::Hub::Interceptor::Terminator(); use Test2::Event::Ok(); use Test2::Event::Diag(); use Test2::Event::Note(); use Test2::Event::Plan(); use Test2::Event::Bail(); use Test2::Event::Exception(); use Test2::Event::Waiting(); use Test2::Event::Skip(); use Test2::Event::Subtest(); use Carp qw/carp croak confess longmess/; use Scalar::Util qw/blessed weaken/; use Test2::Util qw/get_tid/; our @EXPORT_OK = qw{ context release context_do no_context intercept run_subtest test2_init_done test2_load_done test2_pid test2_tid test2_stack test2_no_wait test2_add_callback_context_aquire test2_add_callback_context_init test2_add_callback_context_release test2_add_callback_exit test2_add_callback_post_load test2_list_context_aquire_callbacks test2_list_context_init_callbacks test2_list_context_release_callbacks test2_list_exit_callbacks test2_list_post_load_callbacks test2_ipc test2_ipc_drivers test2_ipc_add_driver test2_ipc_polling test2_ipc_disable_polling test2_ipc_enable_polling test2_ipc_get_pending test2_ipc_set_pending test2_ipc_enable_shm test2_formatter test2_formatters test2_formatter_add test2_formatter_set }; use base 'Exporter'; # 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 noticable performance impact with how often context() is # called. # # This will make sure that Context.pm is loaded the first time this module is # imported, then the regular import method is swapped into place. sub import { require Test2::API::Context unless $INC{'Test2/API/Context.pm'}; { no warnings 'redefine'; *import = \&Exporter::import; } goto &import; } my $STACK = $INST->stack; my $CONTEXTS = $INST->contexts; my $INIT_CBS = $INST->context_init_callbacks; my $AQUIRE_CBS = $INST->context_aquire_callbacks; sub test2_init_done { $INST->finalized } sub test2_load_done { $INST->loaded } sub test2_pid { $INST->pid } sub test2_tid { $INST->tid } sub test2_stack { $INST->stack } sub test2_no_wait { $INST->set_no_wait(@_) if @_; $INST->no_wait; } sub test2_add_callback_context_aquire { $INST->add_context_aquire_callback(@_) } sub test2_add_callback_context_init { $INST->add_context_init_callback(@_) } sub test2_add_callback_context_release { $INST->add_context_release_callback(@_) } sub test2_add_callback_exit { $INST->add_exit_callback(@_) } sub test2_add_callback_post_load { $INST->add_post_load_callback(@_) } sub test2_list_context_aquire_callbacks { @{$INST->context_aquire_callbacks} } sub test2_list_context_init_callbacks { @{$INST->context_init_callbacks} } sub test2_list_context_release_callbacks { @{$INST->context_release_callbacks} } sub test2_list_exit_callbacks { @{$INST->exit_callbacks} } sub test2_list_post_load_callbacks { @{$INST->post_load_callbacks} } sub test2_ipc { $INST->ipc } sub test2_ipc_add_driver { $INST->add_ipc_driver(@_) } sub test2_ipc_drivers { @{$INST->ipc_drivers} } sub test2_ipc_polling { $INST->ipc_polling } sub test2_ipc_enable_polling { $INST->enable_ipc_polling } sub test2_ipc_disable_polling { $INST->disable_ipc_polling } sub test2_ipc_get_pending { $INST->get_ipc_pending } sub test2_ipc_set_pending { $INST->set_ipc_pending(@_) } sub test2_ipc_enable_shm { $INST->ipc_enable_shm } sub test2_formatter { $INST->formatter } sub test2_formatters { @{$INST->formatters} } sub test2_formatter_add { $INST->add_formatter(@_) } sub test2_formatter_set { my ($formater) = @_; croak "No formatter specified" unless $formater; croak "Global Formatter already set" if $INST->formatter_set; $INST->set_formatter($formater); } # Private, for use in Test2::API::Context sub _contexts_ref { $INST->contexts } sub _context_aquire_callbacks_ref { $INST->context_aquire_callbacks } sub _context_init_callbacks_ref { $INST->context_init_callbacks } sub _context_release_callbacks_ref { $INST->context_release_callbacks } # Private, for use in Test2::IPC sub _set_ipc { $INST->set_ipc(@_) } sub context_do(&;@) { my $code = shift; my @args = @_; my $ctx = context(level => 1); my $want = wantarray; my @out; my $ok = eval { $want ? @out = $code->($ctx, @args) : defined($want) ? $out[0] = $code->($ctx, @args) : $code->($ctx, @args) ; 1; }; my $err = $@; $ctx->release; die $err unless $ok; return @out if $want; return $out[0] if defined $want; return; } sub no_context(&;$) { my ($code, $hid) = @_; $hid ||= $STACK->top->hid; my $ctx = $CONTEXTS->{$hid}; delete $CONTEXTS->{$hid}; my $ok = eval { $code->(); 1 }; my $err = $@; $CONTEXTS->{$hid} = $ctx; weaken($CONTEXTS->{$hid}); die $err unless $ok; return; }; sub context { # We need to grab these before anything else to ensure they are not # changed. my ($errno, $eval_error, $child_error) = (0 + $!, $@, $?); my %params = (level => 0, wrapped => 0, @_); # If something is getting a context then the sync system needs to be # considered loaded... $INST->load unless $INST->{loaded}; croak "context() called, but return value is ignored" unless defined wantarray; my $stack = $params{stack} || $STACK; my $hub = $params{hub} || @$stack ? $stack->[-1] : $stack->top; my $hid = $hub->{hid}; my $current = $CONTEXTS->{$hid}; $_->(\%params) for @$AQUIRE_CBS; map $_->(\%params), @{$hub->{_context_aquire}} if $hub->{_context_aquire}; my $level = 1 + $params{level}; my ($pkg, $file, $line, $sub) = caller($level); unless ($pkg) { confess "Could not find context at depth $level" unless $params{fudge}; ($pkg, $file, $line, $sub) = caller(--$level) while ($level >= 0 && !$pkg); } my $depth = $level; $depth++ while caller($depth + 1) && (!$current || $depth <= $current->{_depth} + $params{wrapped}); $depth -= $params{wrapped}; if ($current && $params{on_release} && $current->{_depth} < $depth) { $current->{_on_release} ||= []; push @{$current->{_on_release}} => $params{on_release}; } # I know this is ugly.... ($!, $@, $?) = ($errno, $eval_error, $child_error) and return bless( { %$current, _is_canon => undef, errno => $errno, eval_error => $eval_error, child_error => $child_error, _is_spawn => [$pkg, $file, $line, $sub], }, 'Test2::API::Context' ) if $current && $current->{_depth} < $depth; # 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 $current->{_depth} < $depth; } $current->release if $current->{_is_canon}; delete $CONTEXTS->{$hid}; } # Directly bless the object here, calling new is a noticable performance # hit with how often this needs to be called. my $trace = bless( { frame => [$pkg, $file, $line, $sub], pid => $$, tid => get_tid(), }, 'Test2::Util::Trace' ); # Directly bless the object here, calling new is a noticable performance # hit with how often this needs to be called. my $aborted = 0; $current = bless( { _aborted => \$aborted, stack => $stack, hub => $hub, trace => $trace, _is_canon => 1, _depth => $depth, errno => $errno, eval_error => $eval_error, child_error => $child_error, $params{on_release} ? (_on_release => [$params{on_release}]) : (), }, 'Test2::API::Context' ); $CONTEXTS->{$hid} = $current; weaken($CONTEXTS->{$hid}); $_->($current) for @$INIT_CBS; map $_->($current), @{$hub->{_context_init}} if $hub->{_context_init}; $params{on_init}->($current) if $params{on_init}; ($!, $@, $?) = ($errno, $eval_error, $child_error); return $current; } sub _depth_error { _existing_error(@_, <<" EOT"); context() was called to retrieve an existing context, however the existing context was created in a stack frame at the same, or deeper level. This usually means that a tool failed to release the context when it was finished. EOT } sub _canon_error { _existing_error(@_, <<" EOT"); context() was called to retrieve an existing context, however the existing context has an invalid internal state (!_canon_count). This should not normally happen unless something is mucking about with internals... EOT } sub _existing_error { my ($ctx, $details, $msg) = @_; my ($pkg, $file, $line, $sub, $depth) = @$details; my $oldframe = $ctx->{trace}->frame; my $olddepth = $ctx->{_depth}; my $mess = longmess(); warn <<" EOT"; $msg Old context details: File: $oldframe->[1] Line: $oldframe->[2] Tool: $oldframe->[3] Depth: $olddepth New context details: File: $file Line: $line Tool: $sub Depth: $depth Trace: $mess Removing the old context and creating a new one... EOT } sub release($;$) { $_[0]->release; return $_[1]; } sub intercept(&) { my $code = shift; my $ctx = context(); my $ipc; if (my $global_ipc = test2_ipc()) { my $driver = blessed($global_ipc); $ipc = $driver->new; } my $hub = Test2::Hub::Interceptor->new( ipc => $ipc, no_ending => 1, ); my @events; $hub->listen(sub { push @events => $_[1] }); $ctx->stack->top; # Make sure there is a top hub before we begin. $ctx->stack->push($hub); # Do not use 'try' cause it localizes __DIE__ my ($ok, $err); { $ok = eval { $code->(hub => $hub, context => $ctx->snapshot); 1 }; $err = $@; } $hub->cull; $ctx->stack->pop($hub); my $trace = $ctx->trace; $ctx->release; die $err unless $ok || (blessed($err) && $err->isa('Test2::Hub::Interceptor::Terminator')); $hub->finalize($trace, 1) if $ok && !$hub->no_ending && !$hub->ended; return \@events; } sub run_subtest { my ($name, $code, $buffered, @args) = @_; my $ctx = context(); $ctx->note($name) unless $buffered; my $parent = $ctx->hub; my $stack = $ctx->stack || $STACK; my $hub = $stack->new_hub( class => 'Test2::Hub::Subtest', ); my @events; $hub->set_nested( $parent->isa('Test2::Hub::Subtest') ? $parent->nested + 1 : 1 ); $hub->listen(sub { push @events => $_[1] }); $hub->format(undef) if $buffered; 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"/) { $ok = undef; $err = undef; } else { $finished = 1; } } $stack->pop($hub); my $trace = $ctx->trace; if (!$finished) { if(my $bailed = $hub->bailed_out) { $ctx->bail($bailed->reason); } my $code = $hub->exit_code; $ok = !$code; $err = "Subtest ended with exit code $code" if $code; } $hub->finalize($trace, 1) if $ok && !$hub->no_ending && !$hub->ended; my $pass = $ok && $hub->is_passing; my $e = $ctx->build_event( 'Subtest', pass => $pass, name => $name, buffered => $buffered, subevents => \@events, ); my $plan_ok = $hub->check_plan; $ctx->hub->send($e); $ctx->failure_diag($e) unless $e->pass; $ctx->diag("Caught exception in subtest: $err") unless $ok; $ctx->diag("Bad subtest plan, expected " . $hub->plan . " but ran " . $hub->count) if defined($plan_ok) && !$plan_ok; $ctx->release; return $pass; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API - Primary interface for writing Test2 based testing tools. =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 ***INTERNALS NOTE*** B The public methods provided will not change in backwords 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 SYNOPSYS =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 avabilable on the context object. =head2 TESTING YOUR TOOLS The C tool lets you temporarily intercept all events generated by the test system: use Test2::API qw/intercept/; use My::Ok qw/my_ok/; my $events = intercept { # These events are not displayed my_ok(1, "pass"); my_ok(0, "fail"); }; my_ok(@$events == 2, "got 2 events, the pass and the fail"); my_ok($events->[0]->pass, "first event passed"); my_ok(!$events->[1]->pass, "second event failed"); =head2 OTHER API FUNCTIONS use Test2::API qw{ test2_init_done test2_stack test2_ipc test2_formatter_set test2_formatter }; my $init = test2_init_done(); my $stack = test2_stack(); my $ipc = test2_ipc(); test2_formatter_set($FORMATTER) my $formatter = test2_formatter(); ... And others ... =head1 MAIN API EXPORTS All exports are optional, you must specify subs to import. use Test2::API qw/context intercept run_subtest/; This is the list of exports that are most commonly needed. If you are simply writing a tool then this is probably all you need. If you need something and you cannot find it here then you can also look at L. These exports lack the 'test2_' prefix because of how important/common they are. Exports in the L section have the 'test2_' prefix to ensure they stand out. =head2 context(...) Usage: =over 4 =item $ctx = context() =item $ctx = context(%params) =back The C function will always return the current context to you. 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. =head3 OPTIONAL PARAMETERS All parameters to C are optional. =over 4 =item level => $int If you must obtain a context in a sub deper 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 than 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 aquired. It will capture and rethrow any exception. It will insure the context is released when you are done. It preserves the subroutine call context (array, scalar, void). This is the safest way to write a test tool. The only 2 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(&;$) Useage: =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 aquire one. The new context will be inherited by tools nested below the one that aquired it. This will normally hide the current context for the top hub. If you need to hide the context for a different hub you can pass in the optional C<$hid> parameter. =head2 intercept(&) Usage: my $events = intercept { ok(1, "pass"); ok(0, "fail"); ... }; This function takes a codeblock as its only argument, and it has a prototype. It will execute the codeblock, intercepting any generated events in the process. It will return an array reference with all the generated event objects. All events should be subclasses of L. This is a very low-level subtest tool. This is useful for writing tools which produce subtests. This is not intended for people simply writing tests. =head2 run_subtest(...) Usage: run_subtest($NAME, \&CODE, $BUFFERED, @ARGS) 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 If this is true then the subtest will be buffered. In a buffered subtest the child events are hidden from the formatter, the formatter will only recieve the final L event. In an unbuffered subtest the formatter will see all events as they happen, as well as the final one. =item @ARGS Any extra arguments you want passed into the subtest code. =back =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 responsiblity". 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 $stack = test2_stack() This will return the global L instance. If this has not yet been initialized it will be initialized now. =item $bool = test2_no_wait() =item test2_no_wait($bool) This can be used to get/set the no_wait status. Waiting is turned on by default. Waiting will cause the parent process/thread to wait until all child processes and threads are finished before exiting. You will almost never want to turn this off. =back =head2 BEHAVIOR HOOKS These are hooks that allow you to add custom behavior to actions taken by Test2 and tools built on top of it. =over 4 =item test2_add_callback_exit(sub { ... }) This can be used to add a callback that is called after all testing is done. This is too late to add additional results, the main use of this callback is to set the exit code. test2_add_callback_exit( sub { my ($context, $exit, \$new_exit) = @_; ... } ); The C<$context> passed in will be an instance of L. The C<$exit> argument will be the original exit code before anything modified it. C<$$new_exit> is a reference to the new exit code. You may modify this to change the exit code. Please note that C<$$new_exit> may already be different from C<$exit> =item test2_add_callback_post_load(sub { ... }) Add a callback that will be called when Test2 is finished loading. This means the callback will be run once, the first time a context is obtained. If Test2 has already finished loading then the callback will be run immedietly. =item test2_add_callback_context_aquire(sub { ... }) Add a callback that will be called every time someone tries to aquire a context. This will be called on EVERY call to C. It gets a single argument, a reference the 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_aquire(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 compatability. 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 recieve 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 recieve the released context as its only argument. =item @list = test2_list_context_aquire_callbacks() Return all the context aquire callback references. =item @list = test2_list_context_init_callbacks() Returns all the context init callback references. =item @list = test2_list_context_release_callbacks() Returns all the context release callback references. =item @list = test2_list_exit_callbacks() Returns all the exit callback references. =item @list = test2_list_post_load_callbacks() Returns all the post load callback references. =back =head2 IPC AND CONCURRENCY These let you access, or specify, the IPC system internals. =over 4 =item $ipc = test2_ipc() This will return the global L instance. If this has not yet been initialized it will be initialized now. =item test2_ipc_add_driver($DRIVER) Add an IPC driver to the list. This will add the driver to the start of the list. =item @drivers = test2_ipc_drivers() Get the list of IPC drivers. =item $bool = test2_ipc_polling() Check if polling is enabled. =item test2_ipc_enable_polling() Turn on polling. This will cull events from other processes and threads every time a context is created. =item test2_ipc_disable_polling() Turn off IPC polling. =item test2_ipc_enable_shm() Turn on IPC shm. Only some IPC drivers use this, and most will turn it on themselves. =item test2_ipc_set_pending($uniq_val) Tell other processes and events that an event is pending. C<$uniq_val> should be a unique value no other thread/process will generate. B After calling this C will return 1. This is intentional, and not avoidable. =item $pending = test2_ipc_get_pending() This returns -1 if there is no way to check (assume yes) This returns 0 if there are (most likely) no pending events. This returns 1 if there are (likely) pending events. Upon return it will reset, nothing else will be able to see that there were pending events. =back =head2 MANAGING FORMATTERS These let you access, or specify, the formatters that can/should be used. =over 4 =item $formatter = test2_formatter This will return the global formatter class. This is not an instance. By default the formatter is set to L. You can override this default using the C environment variable. Normally 'Test2::Formatter::' is prefixed to the value in the environment variable: $ T2_FORMATTER='TAP' perl test.t # Use the Test2::Formatter::TAP formatter $ T2_FORMATTER='Foo' perl test.t # Use the Test2::Formatter::Foo formatter If you want to specify a full module name you use the '+' prefix: $ T2_FORMATTER='+Foo::Bar' perl test.t # Use the Foo::Bar formatter =item test2_formatter_set($class_or_instance) Set the global formatter class. This can only be set once. B This will override anything specified in the 'T2_FORMATTER' environment variable. =item @formatters = test2_formatters() Get a list of all loaded formatters. =item test2_formatter_add($class_or_instance) Add a formatter to the list. Last formatter added is used at initialization. If this is called after initialization a warning will be issued. =back =head1 OTHER EXAMPLES See the C directory included in this distribution. =head1 SEE ALSO L - Detailed documentation of the context object. L - The IPC system used for threading/fork support. L - Formatters such as TAP live here. L - Events live in this namespace. L - All events eventually funnel through a hub. Custom hubs are how C and C are implemented. =head1 MAGIC This package has an END block. This END block is responsible for setting the exit code based on the test results. This end block also calls the callbacks that can be added to this package. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 IPC.pm100644001750001750 502312654206301 16062 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2package Test2::IPC; use strict; use warnings; use Test2::API::Instance; use Test2::Util qw/get_tid/; use Test2::API qw{ test2_init_done test2_ipc test2_ipc_enable_polling test2_pid test2_stack test2_tid }; use Carp qw/confess/; our @EXPORT_OK = qw/cull/; use base 'Exporter'; sub import { goto &Exporter::import unless test2_init_done(); confess "Cannot add IPC in a child process" if test2_pid() != $$; confess "Cannot add IPC in a child thread" 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 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 SYNOPSIS You should C as early as possible in your test file. If you import this module after API initialization it will attempt to retrofit IPC onto the existing hubs. =head1 EXPORTS All exports are optional. =over 4 =item cull() Cull allows you to collect results from other processes or threads on demand. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 Hub.pm100644001750001750 4672312654206301 16221 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2package Test2::Hub; use strict; use warnings; use Carp qw/carp croak confess/; use Test2::Util qw/get_tid/; use Scalar::Util qw/weaken/; use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; use Test2::Util::HashBase qw{ pid tid hid ipc no_ending _filters _pre_filters _listeners _follow_ups _formatter _context_aquire _context_init _context_release count failed ended bailed_out _passing _plan skip_reason }; my $ID_POSTFIX = 1; sub init { my $self = shift; $self->{+PID} = $$; $self->{+TID} = get_tid(); $self->{+HID} = join '-', $self->{+PID}, $self->{+TID}, $ID_POSTFIX++; $self->{+COUNT} = 0; $self->{+FAILED} = 0; $self->{+_PASSING} = 1; if (my $formatter = delete $self->{formatter}) { $self->format($formatter); } if (my $ipc = $self->{+IPC}) { $ipc->add_hub($self->{+HID}); } } sub reset_state { my $self = shift; $self->{+COUNT} = 0; $self->{+FAILED} = 0; $self->{+_PASSING} = 1; delete $self->{+_PLAN}; delete $self->{+ENDED}; delete $self->{+BAILED_OUT}; delete $self->{+SKIP_REASON}; } sub inherit { my $self = shift; my ($from, %params) = @_; $self->{+_FORMATTER} = $from->{+_FORMATTER} unless $self->{+_FORMATTER} || exists($params{formatter}); if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { my $ipc = $from->{+IPC}; $self->{+IPC} = $ipc; $ipc->add_hub($self->{+HID}); } if (my $ls = $from->{+_LISTENERS}) { push @{$self->{+_LISTENERS}} => grep { $_->{inherit} } @$ls; } if (my $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; } sub add_context_aquire { my $self = shift; my ($sub) = @_; croak "add_context_aquire only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_CONTEXT_AQUIRE}} => $sub; $sub; # Intentional return. } sub remove_context_aquire { my $self = shift; my %subs = map {$_ => $_} @_; @{$self->{+_CONTEXT_AQUIRE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_AQUIRE}}; } sub add_context_init { my $self = shift; my ($sub) = @_; croak "add_context_init only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_CONTEXT_INIT}} => $sub; $sub; # Intentional return. } sub remove_context_init { my $self = shift; my %subs = map {$_ => $_} @_; @{$self->{+_CONTEXT_INIT}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_INIT}}; } sub add_context_release { my $self = shift; my ($sub) = @_; croak "add_context_release only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_CONTEXT_RELEASE}} => $sub; $sub; # Intentional return. } sub remove_context_release { my $self = shift; my %subs = map {$_ => $_} @_; @{$self->{+_CONTEXT_RELEASE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_RELEASE}}; } sub send { my $self = shift; my ($e) = @_; if ($self->{+_PRE_FILTERS}) { for (@{$self->{+_PRE_FILTERS}}) { $e = $_->{code}->($self, $e); return unless $e; } } my $ipc = $self->{+IPC} || return $self->process($e); if($e->global) { $ipc->send('GLOBAL', $e); return $self->process($e); } return $ipc->send($self->{+HID}, $e) if $$ != $self->{+PID} || get_tid() != $self->{+TID}; $self->process($e); } sub process { my $self = shift; my ($e) = @_; if ($self->{+_FILTERS}) { for (@{$self->{+_FILTERS}}) { $e = $_->{code}->($self, $e); return unless $e; } } my $type = ref($e); my $is_ok = $type eq 'Test2::Event::Ok'; my $no_fail = $type eq 'Test2::Event::Diag' || $type eq 'Test2::Event::Note'; my $causes_fail = $is_ok ? !$e->{effective_pass} : $no_fail ? 0 : $e->causes_fail; $self->{+COUNT}++ if $is_ok || (!$no_fail && $e->increments_count); $self->{+FAILED}++ and $self->{+_PASSING} = 0 if $causes_fail; my $callback = $e->callback($self) unless $is_ok || $no_fail; my $count = $self->{+COUNT}; $self->{+_FORMATTER}->write($e, $count) if $self->{+_FORMATTER}; if ($self->{+_LISTENERS}) { $_->{code}->($self, $e, $count) for @{$self->{+_LISTENERS}}; } return $e if $is_ok || $no_fail; my $code = $e->terminate; $self->terminate($code, $e) if defined $code; 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}; # return if NOTHING was done. return unless $do_plan || defined($plan) || $count || $failed; unless ($self->{+ENDED}) { if ($self->{+_FOLLOW_UPS}) { $_->($trace, $self) for reverse @{$self->{+_FOLLOW_UPS}}; } # These need to be refreshed now $plan = $self->{+_PLAN}; $count = $self->{+COUNT}; $failed = $self->{+FAILED}; if (($plan && $plan eq 'NO PLAN') || ($do_plan && !$plan)) { $self->send( Test2::Event::Plan->new( trace => $trace, max => $count, ) ); } $plan = $self->{+_PLAN}; } my $frame = $trace->frame; if($self->{+ENDED}) { my (undef, $ffile, $fline) = @{$self->{+ENDED}}; my (undef, $sfile, $sline) = @$frame; die <<" EOT" Test already ended! First End: $ffile line $fline Second End: $sfile line $sline EOT } $self->{+ENDED} = $frame; $self->is_passing(); # Generate the final boolean. } sub is_passing { my $self = shift; ($self->{+_PASSING}) = @_ if @_; # If we already failed just return 0. my $pass = $self->{+_PASSING} || 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 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =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 everal 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, which one depends 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, ether 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 1 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_aquire(sub { ... }); Add a callback that will be called every time someone tries to aquire a context. It gets a single argument, a reference the 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_aquire(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 compatability. 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_aquire($sub); This can be used to remove a context aquire hook. =item $sub = $hub->add_context_init(sub { ... }); This allows you to add callbacks that will trigger every time a new context is created for the hub. The only argument to the sub will be the L instance that was created. B Using this hook could have a huge performance impact. The coderef you provide is returned and can be used to remove the hook later. =item $hub->remove_context_init($sub); This can be used to remove a context init hook. =item $sub = $hub->add_context_release(sub { ... }); This allows you to add callbacks that will trigger every time a context for this hub is released. The only argument to the sub will be the L instance that was released. These will run in reverse order. B Using this hook could have a huge performance impact. The coderef you provide is returned and can be used to remove the hook later. =item $hub->remove_context_release($sub); This can be used to remove a context release hook. =item $hub->cull() Cull any IPC events (and process them). =item $pid = $hub->pid() Get the process id under which the hub was created. =item $tid = $hub->tid() Get the thread id under which the hub was created. =item $hud = $hub->hid() Get the identifier string of the hub. =item $ipc = $hub->ipc() Get the IPC object used by the hub. =item $hub->set_no_ending($bool) =item $bool = $hub->no_ending This can be used to disable auto-ending behavior for a hub. The auto-ending behavior is triggered by an end block and is used to cull IPC events, and output the final plan if the plan was 'no_plan'. =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 guarenteed. =item $bool = $hub->is_passing =item $hub->is_passing($bool) Check if the overall test run is a failure. Can also be used to set the pass/fail status. =item $hub->plan($plan) =item $plan = $hub->plan Get or set the plan. The plan must be an integer larger than 0, the string 'no_plan', or the string 'skip_all'. =item $bool = $hub->check_plan Check if the plan and counts match, but only if the tests have ended. If tests have not unded 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 extentions. =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 2015 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 Examples000755001750001750 012654206301 14760 5ustar00exodistexodist000000000000Test2-0.000025tools.t100644001750001750 1107212654206301 16466 0ustar00exodistexodist000000000000Test2-0.000025/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 propogated" ); $events = intercept { test2_stack()->top->set_no_ending(0); ok(1); }; is(@$events, 2, "2 events"); ok($events->[0]->isa('Test2::Event::Ok'), "got ok"); ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called"); $events = intercept { test2_stack()->top->set_no_ending(0); ok(1); done_testing; }; is(@$events, 2, "2 events"); ok($events->[0]->isa('Test2::Event::Ok'), "got ok"); ok($events->[1]->isa('Test2::Event::Plan'), "finalize was called (only 1 plan)"); done_testing; Util.t100644001750001750 136412654206301 16363 0ustar00exodistexodist000000000000Test2-0.000025/t/modulesuse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::Util qw/ try get_tid USE_THREADS pkg_to_file CAN_FORK CAN_THREAD CAN_REALLY_FORK /; { 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(); done_testing; Util.pm100644001750001750 1217212654206301 16407 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2package Test2::Util; use strict; use warnings; use Config qw/%Config/; our @EXPORT_OK = qw{ try pkg_to_file get_tid USE_THREADS CAN_THREAD CAN_REALLY_FORK CAN_FORK }; use base 'Exporter'; sub _can_thread { return 0 unless $] >= 5.008001; return 0 unless $Config{'useithreads'}; # Threads are broken on perl 5.10.0 built with gcc 4.8+ if ($] == 5.010000 && $Config{'ccname'} eq 'gcc' && $Config{'gccversion'}) { my @parts = split /\./, $Config{'gccversion'}; return 0 if $parts[0] >= 4 && $parts[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 $^O eq 'MSWin32' || $^O eq 'NetWare'; return 0 unless $Config{useithreads}; return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/; return _can_thread(); } BEGIN { no warnings 'once'; *CAN_REALLY_FORK = $Config{d_fork} ? sub() { 1 } : sub() { 0 }; *CAN_THREAD = _can_thread() ? sub() { 1 } : sub() { 0 }; *CAN_FORK = _can_fork() ? sub() { 1 } : sub() { 0 }; } 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 ($^O eq 'MSWin32' && $] < 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; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util - Tools used by Test2 and friends. =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =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 psuedo-fork. =item CAN_REALLY_FORK True if the system can really fork. This will be false for systems where fork is emulated. =item CAN_THREAD True if this system is capable of using threads. =item USE_THREADS Returns true if threads are enabled, false if they are not. =item get_tid This will return the id of the current thread when threads are enabled, otherwise it returns 0. =item my $file = pkg_to_file($package) Convert a package name to a filename. =back =head1 NOTES && CAVEATS =over 4 =item 5.10.0 Perl 5.10.0 has a bug when compiled with newer gcc versions. This bug causes a segfault whenever a new thread is launched. Test2 will attempt to detect this, and note that the system is not capable of forking when it is detected. =item Devel::Cover Devel::Cover does not support threads. CAN_THREAD will return false if Devel::Cover is loaded before the check is first run. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =item Kent Fredric Ekentnl@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 tools.pl100644001750001750 577512654206301 16633 0ustar00exodistexodist000000000000Test2-0.000025/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; Event.t100644001750001750 147712654206301 16534 0ustar00exodistexodist000000000000Test2-0.000025/t/modulesuse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::Event(); { package My::MockEvent; use base 'Test2::Event'; use Test2::Util::HashBase qw/foo bar baz/; } ok(My::MockEvent->can($_), "Added $_ accessor") for qw/foo bar baz/; my $one = My::MockEvent->new(trace => 'fake'); ok(!$one->causes_fail, "Events do not cause failures by default"); ok(!$one->$_, "$_ is false by default") for qw/increments_count terminate global/; ok(!$one->get_meta('xxx'), "no meta-data associated for key 'xxx'"); $one->set_meta('xxx', '123'); is($one->meta('xxx'), '123', "got meta-data"); is($one->meta('xxx', '321'), '123', "did not use default"); is($one->meta('yyy', '1221'), '1221', "got the default"); is($one->meta('yyy'), '1221', "last call set the value to the default for future use"); done_testing; Event.pm100644001750001750 1003412654206301 16546 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2package Test2::Event; use strict; use warnings; use Test2::Util::HashBase qw/trace nested/; use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; sub causes_fail { 0 } sub increments_count { 0 } sub callback { } sub terminate { () } sub global { () } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event - Base class for events =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 DESCRIPTION Base class for all event objects that get passed through L. =head1 SYNOPSIS package Test2::Event::MyEvent; use strict; use warnings; # This will make our class an event subclass (required) use base 'Test2::Event'; # Add some accessors (optional) # You are not obligated to use HashBase, you can use any object tool you # want, or roll your own accessors. use Test2::Util::HashBase qw/foo bar baz/; # Chance to initialize some defaults sub init { my $self = shift; # no other args in @_ $self->set_foo('xxx') unless defined $self->foo; ... } 1; =head1 METHODS =over 4 =item $trace = $e->trace Get a snapshot of the L as it was when this event was generated =item $bool = $e->causes_fail Returns true if this event should result in a test failure. In general this should be false. =item $bool = $e->increments_count Should be true if this event should result in a test count increment. =item $e->callback($hub) If your event needs to have extra effects on the L you can override this method. This is called B your event is passed to the formatter. =item $call = $e->created Get the C details from when the event was generated. This is usually inside a tools package. This is typically used for debugging. =item $num = $e->nested If this event is nested inside of other events, this should be the depth of nesting. (This is mainly for subtests) =item $bool = $e->global Set this to true if your event is global, that is ALL threads and processes should see it no matter when or where it is generated. This is not a common thing to want, it is used by bail-out and skip_all to end testing. =item $code = $e->terminate This is called B your event has been passed to the formatter. This should normally return undef, only change this if your event should cause the test to exit immedietly. If you want this event to cause the test to exit you should return the exit code here. Exit code of 0 means exit success, any other integer means exit with failure. This is used by L to exit 0 when the plan is 'skip_all'. This is also used by L to force the test to exit with a failure. This is called after the event has been sent to the formatter in order to ensure the event is seen and understood. =item $todo = $e->todo =item $e->set_todo($todo) Get/Set the todo reason on the event. Any value other than C makes the event 'TODO'. Not all events make use of this field, but they can all have it set/cleared. =item $bool = $e->diag_todo =item $e->diag_todo($todo) True if this event should be considered 'TODO' for diagnostics purposes. This essentially means that any message that would go to STDERR will go to STDOUT instead so that a harness will hide it outside of verbose mode. =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 extentions. =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 2015 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 behavior000755001750001750 012654206301 15244 5ustar00exodistexodist000000000000Test2-0.000025/tTaint.t100644001750001750 51412654206301 16630 0ustar00exodistexodist000000000000Test2-0.000025/t/behavior#!/usr/bin/env perl -T 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; err_var.t100644001750001750 27112654206301 17211 0ustar00exodistexodist000000000000Test2-0.000025/t/behavioruse strict; use warnings; use Test2::IPC; BEGIN { require "t/tools.pl" }; { local $! = 100; is(0 + $!, 100, 'set $!'); is(0 + $!, 100, 'preserved $!'); } done_testing; Event000755001750001750 012654206301 16176 5ustar00exodistexodist000000000000Test2-0.000025/t/modulesOk.t100644001750001750 474512654206301 17106 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/Eventuse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::Util::Trace; use Test2::Event::Ok; use Test2::Event::Diag; use Test2::API qw/context/; my $trace; sub before_each { # Make sure there is a fresh trace object for each group $trace = Test2::Util::Trace->new( frame => ['main_foo', 'foo.t', 42, 'main_foo::flubnarb'], ); } tests Passing => sub { my $ok = Test2::Event::Ok->new( trace => $trace, pass => 1, name => 'the_test', ); ok($ok->increments_count, "Bumps the count"); ok(!$ok->causes_fail, "Passing 'OK' event does not cause failure"); is($ok->pass, 1, "got pass"); is($ok->name, 'the_test', "got name"); is($ok->effective_pass, 1, "effective pass"); }; 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"); }; 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"); $ok = Test2::Event::Ok->new( trace => $trace, pass => 0, name => 'the_test2', todo => '', ); ok($ok->effective_pass, "empty string todo is still a todo"); }; tests init => sub { like( exception { Test2::Event::Ok->new(trace => $trace, pass => 1, name => "foo#foo") }, qr/'foo#foo' is not a valid name, names must not contain '#' or newlines/, "Some characters do not belong in a name" ); like( exception { Test2::Event::Ok->new(trace => $trace, pass => 1, name => "foo\nfoo") }, qr/'foo\nfoo' is not a valid name, names must not contain '#' or newlines/, "Some characters do not belong in a name" ); my $ok = Test2::Event::Ok->new( trace => $trace, pass => 1, ); is($ok->effective_pass, 1, "set effective pass"); }; done_testing; Event000755001750001750 012654206301 16032 5ustar00exodistexodist000000000000Test2-0.000025/lib/Test2Ok.pm100644001750001750 475312654206301 17112 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Eventpackage Test2::Event::Ok; use strict; use warnings; use base '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); my $name = $self->{+NAME} or return; return unless index($name, '#') != -1 || index($name, "\n") != -1; $self->trace->throw("'$name' is not a valid name, names must not contain '#' or newlines.") } { 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} } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Ok - Ok event type =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =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, diag => \@diag ); =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 $diag = $e->diag An arrayref full of diagnostics strings to print in the event of a failure. =item $b = $e->effective_pass This is the true/false value of the test after TODO and similar modifiers are taken into account. =item $b = $e->allow_bad_name This relaxes the test name checks such that they allow characters that can confuse a TAP parser. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 API000755001750001750 012654206301 15526 5ustar00exodistexodist000000000000Test2-0.000025/t/modulesStack.t100644001750001750 351112654206301 17120 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/APIuse strict; use warnings; use Test2::IPC; BEGIN { require "t/tools.pl" }; 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; Formatter.pm100644001750001750 321512654206301 17413 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2package Test2::Formatter; use strict; use warnings; use Test2::API qw/test2_formatter_add/; my %ADDED; sub import { my $class = shift; return if $class eq __PACKAGE__; return if $ADDED{$class}++; test2_formatter_add($class); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Formatter - Namespace for formatters. =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =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) = @_; ... } 1; The C method is a method, so it either gets a class or instance. The 2 arguments are the C<$event> object it should record, and the C<$assert_num> which is the number of the current assertion (ok), or the last assertion if this even is not itself an assertion. The assertion number may be any inyeger 0 or greator, and may be undefined in some cases. =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 2015 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 API000755001750001750 012654206301 15362 5ustar00exodistexodist000000000000Test2-0.000025/lib/Test2Stack.pm100644001750001750 1135512654206301 17152 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/APIpackage Test2::API::Stack; use strict; use warnings; use Test2::Hub(); use Carp qw/confess/; sub new { my $class = shift; return bless [], $class; } sub new_hub { my $self = shift; my %params = @_; my $class = delete $params{class} || 'Test2::Hub'; my $hub = $class->new(%params); if (@$self) { $hub->inherit($self->[-1], %params); } else { require Test2::API; $hub->format(Test2::API::test2_formatter()->new) unless $hub->format || exists($params{formatter}); my $ipc = Test2::API::test2_ipc(); if ($ipc && !$hub->ipc && !exists($params{ipc})) { $hub->set_ipc($ipc); $ipc->add_hub($hub->hid); } } push @$self => $hub; $hub; } sub top { my $self = shift; return $self->new_hub unless @$self; return $self->[-1]; } sub peek { my $self = shift; return @$self ? $self->[-1] : undef; } sub cull { my $self = shift; $_->cull for reverse @$self; } sub all { my $self = shift; return @$self; } sub clear { my $self = shift; @$self = (); } # Do these last without keywords in order to prevent them from getting used # when we want the real push/pop. { no warnings 'once'; *push = sub { my $self = shift; my ($hub) = @_; $hub->inherit($self->[-1]) if @$self; push @$self => $hub; }; *pop = sub { my $self = shift; my ($hub) = @_; confess "No hubs on the stack" unless @$self; confess "You cannot pop the root hub" if 1 == @$self; confess "Hub stack mismatch, attempted to pop incorrect hub" unless $self->[-1] == $hub; pop @$self; }; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::Stack - Object to manage a stack of L instances. =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 ***INTERNALS NOTE*** B The public methods provided will not change in backwords incompatible ways, but the underlying implementation details might. B =head1 DESCRIPTION This module is used to represent and manage a stack of L objects. Hubs are usually in a stack so that you can push a new hub into place that can intercept and handle events differently than the primary hub. =head1 SYNOPSIS my $stack = Test2::API::Stack->new; my $hub = $stack->top; =head1 METHODS =over 4 =item $stack = Test2::API::Stack->new() This will create a new empty stack instance. All arguments are ignored. =item $hub = $stack->new_hub() =item $hub = $stack->new_hub(%params) =item $hub = $stack->new_hub(%params, class => $class) This will generate a new hub and push it to the top of the stack. Optionally you can provide arguments that will be passed into the constructor for the L object. If you specify the C<< 'class' => $class >> argument, the new hub will be an instance of the specified class. Unless your parameters specify C<'formatter'> or C<'ipc'> arguments, the formatter and ipc instance will be inherited from the current top hub. You can set the parameters to C to avoid having a formatter or ipc instance. If there is no top hub, and you do not ask to leave ipc and formatter undef, then a new formatter will be created, and the IPC instance from L will be used. =item $hub = $stack->top() This will return the top hub from the stack. If there is no top hub yet this will create it. =item $hub = $stack->peek() This will return the top hub from the stack. If there is no top hub yet this will return undef. =item $stack->cull This will call C<< $hub->cull >> on all hubs in the stack. =item @hubs = $stack->all This will return all the hubs in the stack as a list. =item $stack->clear This will completely remove all hubs from the stack. Normally you do not want to do this, but there are a few valid reasons for it. =item $stack->push($hub) This will push the new hub onto the stack. =item $stack->pop($hub) This will pop a hub from the stack, if the hub at the top of the stack does not match the hub you expect (passed in as an argument) it will throw an exception. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 Util000755001750001750 012654206301 16032 5ustar00exodistexodist000000000000Test2-0.000025/t/modulesTrace.t100644001750001750 217112654206301 17416 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/Utiluse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::Util::Trace; like( exception { 'Test2::Util::Trace'->new() }, qr/The 'frame' attribute is required/, "got error" ); my $one = 'Test2::Util::Trace'->new(frame => ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo']); is_deeply($one->frame, ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got frame"); is_deeply([$one->call], ['Foo::Bar', 'foo.t', 5, 'Foo::Bar::foo'], "Got call"); is($one->package, 'Foo::Bar', "Got package"); is($one->file, 'foo.t', "Got file"); is($one->line, 5, "Got line"); is($one->subname, 'Foo::Bar::foo', "got subname"); is($one->debug, "at foo.t line 5", "got trace"); $one->set_detail("yo momma"); is($one->debug, "yo momma", "got detail for trace"); $one->set_detail(undef); is( exception { $one->throw('I died') }, "I died at foo.t line 5.\n", "got exception" ); is_deeply( warnings { $one->alert('I cried') }, [ "I cried at foo.t line 5.\n" ], "alter() warns" ); my $snap = $one->snapshot; is_deeply($snap, $one, "identical"); ok($snap != $one, "Not the same instance"); done_testing; Diag.t100644001750001750 124412654206301 17370 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/Eventuse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::Event::Diag; use Test2::Util::Trace; my $diag = Test2::Event::Diag->new( trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => 'foo', ); $diag = Test2::Event::Diag->new( trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => undef, ); is($diag->message, 'undef', "set undef message to undef"); $diag = Test2::Event::Diag->new( trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => {}, ); like($diag->message, qr/^HASH\(.*\)$/, "stringified the input value"); done_testing; Note.t100644001750001750 124512654206301 17432 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/Eventuse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::Event::Note; use Test2::Util::Trace; my $note = Test2::Event::Note->new( trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => 'foo', ); $note = Test2::Event::Note->new( trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => undef, ); is($note->message, 'undef', "set undef message to undef"); $note = Test2::Event::Note->new( trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), message => {}, ); like($note->message, qr/^HASH\(.*\)$/, "stringified the input value"); done_testing; Skip.t100644001750001750 73712654206301 17420 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/EventBEGIN { require "t/tools.pl" }; use strict; use warnings; use Test2::Event::Skip; use Test2::Util::Trace; my $skip = Test2::Event::Skip->new( trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), name => 'skip me', reason => 'foo', ); is($skip->name, 'skip me', "set name"); is($skip->reason, 'foo', "got skip reason"); ok(!$skip->pass, "no default for pass"); ok($skip->effective_pass, "TODO always effectively passes"); done_testing; Bail.t100644001750001750 102312654206301 17366 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/Eventuse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::Event::Bail; my $bail = Test2::Event::Bail->new( trace => 'fake', reason => 'evil', ); ok($bail->causes_fail, "bailout always causes fail."); is($bail->terminate, 255, "Bail will cause the test to exit."); is($bail->global, 1, "Bail is global, everything should bail"); my $hub = Test2::Hub->new; ok($hub->is_passing, "passing"); ok(!$hub->failed, "no failures"); $bail->callback($hub); is($hub->bailed_out, $bail, "set bailed out"); done_testing; Plan.t100644001750001750 534312654206301 17422 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/Eventuse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::Event::Plan; use Test2::Util::Trace; my $plan = Test2::Event::Plan->new( trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 100, ); ok(!$plan->global, "regular plan is not a global event"); my $state = Test2::Hub->new; $plan->callback($state); is($state->plan, 100, "set plan in state"); is($plan->terminate, undef, "No terminate for normal plan"); $plan->set_max(0); $plan->set_directive('SKIP'); $plan->set_reason('foo'); ok($plan->global, "plan is global on skip all"); $state = Test2::Hub->new; $plan->callback($state); is($state->plan, 'SKIP', "set plan in state"); is($plan->terminate, 0, "Terminate 0 on skip_all"); $plan->set_max(0); $plan->set_directive('NO PLAN'); $plan->set_reason(undef); $state = Test2::Hub->new; $plan->callback($state); is($state->plan, 'NO PLAN', "set plan in state"); is($plan->terminate, undef, "No terminate for no_plan"); $plan->set_max(100); $plan->set_directive(undef); $plan->callback($state); is($state->plan, '100', "Update plan in state if it is 'NO PLAN'"); $plan = Test2::Event::Plan->new( trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'skip_all', ); is($plan->directive, 'SKIP', "Change skip_all to SKIP"); $plan = Test2::Event::Plan->new( trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'no_plan', ); is($plan->directive, 'NO PLAN', "Change no_plan to 'NO PLAN'"); ok(!$plan->global, "NO PLAN is not global"); like( exception { $plan = Test2::Event::Plan->new( trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, directive => 'foo', ); }, qr/'foo' is not a valid plan directive/, "Invalid Directive" ); like( exception { $plan = Test2::Event::Plan->new( trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 0, reason => 'foo', ); }, qr/Cannot have a reason without a directive!/, "Reason without directive" ); like( exception { $plan = Test2::Event::Plan->new( trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), ); }, qr/No number of tests specified/, "Nothing to do" ); like( exception { $plan = Test2::Event::Plan->new( trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__]), max => 'skip', ); }, qr/Plan test count 'skip' does not appear to be a valid positive integer/, "Max must be an integer" ); done_testing; IPC000755001750001750 012654206301 15530 5ustar00exodistexodist000000000000Test2-0.000025/t/modulesDriver.t100644001750001750 251412654206301 17312 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/IPCuse strict; use warnings; use Test2::IPC::Driver::Files; BEGIN { require "t/tools.pl" }; use Test2::API qw/context test2_ipc_drivers/; Test2::IPC::Driver::Files->import(); Test2::IPC::Driver::Files->import(); Test2::IPC::Driver::Files->import(); is_deeply( [test2_ipc_drivers()], ['Test2::IPC::Driver::Files'], "Driver not added multiple times" ); for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) { my $one = Test2::IPC::Driver->new; like( exception { $one->$meth }, qr/'\Q$one\E' did not define the required method '$meth'/, "Require override of method $meth" ); } tests abort => sub { my $one = Test2::IPC::Driver->new(no_fatal => 1); my ($err, $out) = ("", ""); { local *STDERR; local *STDOUT; open(STDERR, '>', \$err); open(STDOUT, '>', \$out); $one->abort('foo'); } is($err, "IPC Fatal Error: foo\n", "Got error"); is($out, "not ok - IPC Fatal Error\n", "got 'not ok' on stdout"); ($err, $out) = ("", ""); { local *STDERR; local *STDOUT; open(STDERR, '>', \$err); open(STDOUT, '>', \$out); $one->abort_trace('foo'); } is($out, "not ok - IPC Fatal Error\n", "got 'not ok' on stdout"); like($err, qr/IPC Fatal Error: foo/, "Got error"); }; done_testing; Util000755001750001750 012654206301 15666 5ustar00exodistexodist000000000000Test2-0.000025/lib/Test2Trace.pm100644001750001750 574612654206301 17436 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Utilpackage Test2::Util::Trace; use strict; use warnings; use Test2::Util qw/get_tid/; use Carp qw/confess/; use Test2::Util::HashBase qw{frame detail pid tid}; sub init { confess "The 'frame' attribute is required" unless $_[0]->{+FRAME}; $_[0]->{+PID} ||= $$; $_[0]->{+TID} ||= get_tid(); } sub snapshot { bless {%{$_[0]}}, __PACKAGE__ }; sub debug { my $self = shift; return $self->{+DETAIL} if $self->{+DETAIL}; my ($pkg, $file, $line) = $self->call; return "at $file line $line"; } sub alert { my $self = shift; my ($msg) = @_; warn $msg . ' ' . $self->debug . ".\n"; } sub throw { my $self = shift; my ($msg) = @_; die $msg . ' ' . $self->debug . ".\n"; } sub call { @{$_[0]->{+FRAME}} } sub package { $_[0]->{+FRAME}->[0] } sub file { $_[0]->{+FRAME}->[1] } sub line { $_[0]->{+FRAME}->[2] } sub subname { $_[0]->{+FRAME}->[3] } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::Trace - Debug information for events =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 DESCRIPTION The L object, as well as all L types need to have access to information about where they were created. This object represents that information. =head1 SYNOPSIS use Test2::Util::Trace; my $trace = Test2::Util::Trace->new( frame => [$package, $file, $line, $subname], ); =head1 METHODS =over 4 =item $trace->set_detail($msg) =item $msg = $trace->detail Used to get/set a custom trace message that will be used INSTEAD of C<< at line >> when calling C<< $trace->debug >>. =item $str = $trace->debug Typically returns the string C<< at line >>. If C is set then its value wil be returned instead. =item $trace->alert($MESSAGE) This issues a warning at the frame (filename and line number where errors should be reported). =item $trace->throw($MESSAGE) This throws an exception at the frame (filename and line number where errors should be reported). =item $frame = $trace->frame() Get the call frame arrayref. =item ($package, $file, $line, $subname) = $trace->call() Get the caller details for the debug-info. This is where errors should be reported. =item $pkg = $trace->package Get the debug-info package. =item $file = $trace->file Get the debug-info filename. =item $line = $trace->line Get the debug-info line number. =item $subname = $trace->subname Get the debug-info subroutine name. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 Note.pm100644001750001750 222312654206301 17434 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Eventpackage Test2::Event::Note; use strict; use warnings; use base 'Test2::Event'; use Test2::Util::HashBase qw/message/; sub init { $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Note - Note event type =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 DESCRIPTION Notes, typically rendered to STDOUT. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Note; my $ctx = context(); my $event = $ctx->Note($message); =head1 ACCESSORS =over 4 =item $note->message The message for the note. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 Diag.pm100644001750001750 224212654206301 17374 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Eventpackage Test2::Event::Diag; use strict; use warnings; use base 'Test2::Event'; use Test2::Util::HashBase qw/message/; sub init { $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Diag - Diag event type =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 DESCRIPTION Diagnostics messages, typically rendered to STDERR. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Diag; my $ctx = context(); my $event = $ctx->diag($message); =head1 ACCESSORS =over 4 =item $diag->message The message for the diag. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 Bail.pm100644001750001750 260612654206301 17403 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Eventpackage Test2::Event::Bail; use strict; use warnings; use base 'Test2::Event'; use Test2::Util::HashBase qw{reason}; sub callback { my $self = shift; my ($hub) = @_; $hub->set_bailed_out($self); } # Make sure the tests terminate sub terminate { 255 }; sub global { 1 }; sub causes_fail { 1 } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Bail - Bailout! =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 DESCRIPTION The bailout event is generated when things go horribly wrong and you need to halt all testing in the current file. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Bail; my $ctx = context(); my $event = $ctx->bail('Stuff is broken'); =head1 METHODS Inherits from L. Also defines: =over 4 =item $reason = $e->reason The reason for the bailout. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 Skip.pm100644001750001750 274212654206301 17443 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Eventpackage Test2::Event::Skip; use strict; use warnings; use base '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 } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Skip - Skip event type =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 DESCRIPTION Skip events bump test counts just like L events, but they can never fail. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Skip; my $ctx = context(); my $event = $ctx->skip($name, $reason); or: my $ctx = context(); my $event = $ctx->send_event( 'Skip', name => $name, reason => $reason, ); =head1 ACCESSORS =over 4 =item $reason = $e->reason The original true/false value of whatever was passed into the event (but reduced down to 1 or 0). =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 Plan.pm100644001750001750 543612654206301 17432 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Eventpackage Test2::Event::Plan; use strict; use warnings; use base '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 callback { my $self = shift; my ($hub) = @_; $hub->plan($self->{+DIRECTIVE} || $self->{+MAX}); return unless $self->{+DIRECTIVE}; $hub->set_skip_reason($self->{+REASON} || 1) if $self->{+DIRECTIVE} eq 'SKIP'; } sub terminate { my $self = shift; # On skip_all we want to terminate the hub return 0 if $self->{+DIRECTIVE} && $self->{+DIRECTIVE} eq 'SKIP'; return undef; } sub global { my $self = shift; return 0 unless $self->{+DIRECTIVE}; return 0 unless $self->{+DIRECTIVE} eq 'SKIP'; return 1; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Plan - The event of a plan =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 DESCRIPTION Plan events are fired off whenever a plan is declared, done testing is called, or a subtext completes. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Plan; my $ctx = context(); # Plan for 10 tests to run my $event = $ctx->plan(10); # Plan to skip all tests (will exit 0) $ctx->plan(0, skip_all => "These tests need to be skipped"); =head1 ACCESSORS =over 4 =item $num = $plan->max Get the number of expected tests =item $dir = $plan->directive Get the directive (such as TODO, skip_all, or no_plan). =item $reason = $plan->reason Get the reason for the directive. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 012654206301 15364 5ustar00exodistexodist000000000000Test2-0.000025/lib/Test2Driver.pm100644001750001750 1461212654206301 17341 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/IPCpackage Test2::IPC::Driver; use strict; use warnings; use Carp qw/confess longmess/; use Test2::Util::HashBase qw{no_fatal}; use Test2::API qw/test2_ipc_add_driver/; my %ADDED; sub import { my $class = shift; return if $class eq __PACKAGE__; return if $ADDED{$class}++; test2_ipc_add_driver($class); } sub use_shm { 0 } for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) { no strict 'refs'; *$meth = sub { my $thing = shift; confess "'$thing' did not define the required method '$meth'." }; } # Print the error and call exit. We are not using 'die' cause this is a # catastophic error that should never be caught. If we get here it # means some serious shit has happened in a child process, the only way # to inform the parent may be to exit false. sub abort { my $self = shift; chomp(my ($msg) = @_); print STDERR "IPC Fatal Error: $msg\n"; print STDOUT "not ok - IPC Fatal Error\n"; CORE::exit(255) unless $self->no_fatal; } sub abort_trace { my $self = shift; my ($msg) = @_; $self->abort(longmess($msg)); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::IPC::Driver - Base class for Test2 IPC drivers. =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 SYNOPSIS package Test2::IPC::Driver::MyDriver; use base 'Test2::IPC::Driver'; ... =head1 METHODS =over 4 =item $self->abort($msg) If an IPC encounters a fatal error it should use this. This will print the message to STDERR with C<'IPC Fatal Error: '> prefixed to it, then it will forcefully exit 255. IPC errors may occur in threads or processes other than the main one, this method provides the best chance of the harness noticing the error. =item $self->abort_trace($msg) This is the same as C<< $ipc->abort($msg) >> except that it uses C to add a stack trace to the message. =item $false = $self->use_shm The base class always returns false for this method. You may override it if you wish to use the SHM made avilable in L/L. =back =head1 LOADING DRIVERS Test2::IPC::Driver has an C method. All drivers inherit this import method. This import method registers the driver. In most cases you just need to load the desired IPC driver to make it work. You should load this driver as early as possible. A warning will be issued if you load it too late for it to be effective. use Test2::IPC::Driver::MyDriver; ... =head1 WRITING DRIVERS package Test2::IPC::Driver::MyDriver; use strict; use warnings; use base 'Test2::IPC::Driver'; sub is_viable { return 0 if $^O eq 'win32'; # Will not work on windows. return 1; } sub add_hub { my $self = shift; my ($hid) = @_; ... # Make it possible to contact the hub } sub drop_hub { my $self = shift; my ($hid) = @_; ... # Nothing should try to reach the hub anymore. } sub send { my $self = shift; my ($hid, $e) = @_; ... # Send the event to the proper hub. # If you are using the SHM you should notify other procs/threads that # there is a pending event. Test2::API::test2_ipc_set_pending($uniq_val); } sub cull { my $self = shift; my ($hid) = @_; my @events = ...; # Here is where you get the events for the hub return @events; } sub waiting { my $self = shift; ... # Notify all listening procs and threads that the main ... # process/thread is waiting for them to finish. } 1; =head2 METHODS SUBCLASSES MUST IMPLEMENT =over 4 =item $ipc->is_viable This should return true if the driver works in the current environment. This should return false if it does not. This is a CLASS method. =item $ipc->add_hub($hid) This is used to alert the driver that a new hub is expecting events. The driver should keep track of the process and thread ids, the hub should only be dropped by the proc+thread that started it. sub add_hub { my $self = shift; my ($hid) = @_; ... # Make it possible to contact the hub } =item $ipc->drop_hub($hid) This is used to alert the driver that a hub is no longer accepting events. The driver should keep track of the process and thread ids, the hub should only be dropped by the proc+thread that started it (This is the drivers responsibility to enforce). sub drop_hub { my $self = shift; my ($hid) = @_; ... # Nothing should try to reach the hub anymore. } =item $ipc->send($hid, $event); Used to send events from the current process/thread to the specified hub in its process+thread. sub send { my $self = shift; my ($hid, $e) = @_; ... # Send the event to the proper hub. # If you are using the SHM you should notify other procs/threads that # there is a pending event. Test2::API::test2_ipc_set_pending($uniq_val); } =item @events = $ipc->cull($hid) Used to collect events that have been sent to the specified hub. sub cull { my $self = shift; my ($hid) = @_; my @events = ...; # Here is where you get the events for the hub return @events; } =item $ipc->waiting() This is called in the parent process when it is complete and waiting for all child processes and threads to complete. sub waiting { my $self = shift; ... # Notify all listening procs and threads that the main ... # process/thread is waiting for them to finish. } =back =head2 METHODS SUBCLASSES MAY IMPLEMENT OR OVERRIDE =over 4 =item $bool = $ipc->use_shm() True if you want to make use of the L/L SHM. =item $bites = $ipc->shm_size() Use this to customize the size of the shm space. There are no guarentees about what the size will be if you do not implement this. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 Hub000755001750001750 012654206301 15633 5ustar00exodistexodist000000000000Test2-0.000025/t/modulesSubtest.t100644001750001750 376212654206301 17621 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/Hubuse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::Hub::Subtest; use Carp qw/croak/; my %TODO; sub def { my ($func, @args) = @_; my @caller = caller(0); $TODO{$caller[0]} ||= []; push @{$TODO{$caller[0]}} => [$func, \@args, \@caller]; } sub do_def { my $for = caller; my $tests = delete $TODO{$for} or croak "No tests to run!"; for my $test (@$tests) { my ($func, $args, $caller) = @$test; my ($pkg, $file, $line) = @$caller; # Note: The '&' below is to bypass the prototype, which is important here. eval <<" EOT" or die $@; package $pkg; # line $line "(eval in DeferredTests) $file" \&$func(\@\$args); 1; EOT } } my $ran = 0; my $event; my $one = Test2::Hub::Subtest->new( nested => 3, ); ok($one->isa('Test2::Hub'), "inheritence"); { no warnings 'redefine'; local *Test2::Hub::process = sub { $ran++; (undef, $event) = @_; 'P!' }; use warnings; my $ok = Test2::Event::Ok->new( pass => 1, name => 'blah', trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']), ); def is => ($one->process($ok), 'P!', "processed"); def is => ($ran, 1, "ran the mocked process"); def is => ($event, $ok, "got our event"); def is => ($event->nested, 3, "nested was set"); def is => ($one->bailed_out, undef, "did not bail"); $ran = 0; $event = undef; my $bail = Test2::Event::Bail->new( message => 'blah', trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']), ); def is => ($one->process($bail), 'P!', "processed"); def is => ($ran, 1, "ran the mocked process"); def is => ($event, $bail, "got our event"); def is => ($event->nested, 3, "nested was set"); def is => ($one->bailed_out, $event, "bailed"); } do_def; $ran = 0; T2_SUBTEST_WRAPPER: { $ran++; $one->terminate(100); $ran++; } is($ran, 1, "did not get past the terminate"); done_testing; Context.t100644001750001750 3000312654206301 17513 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/APIuse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::API qw{ context intercept test2_stack test2_add_callback_context_aquire 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__, 'main::END' ]; $end_ctx = $ctx->snapshot; $ctx->release; } delete $end_ctx->trace->frame->[4]; is_deeply( $end_ctx->trace->frame, $frame, 'context is ok in an end block'); # Test event generation { package My::Formatter; sub write { my $self = shift; my ($e) = @_; push @$self => $e; } } my $events = bless [], 'My::Formatter'; my $hub = Test2::Hub->new( formatter => $events, ); my $trace = Test2::Util::Trace->new( frame => [ 'Foo::Bar', 'foo_bar.t', 42, 'Foo::Bar::baz' ], ); my $ctx = Test2::API::Context->new( trace => $trace, hub => $hub, ); my $e = $ctx->build_event('Ok', pass => 1, name => 'foo'); is($e->pass, 1, "Pass"); is($e->name, 'foo', "got name"); is_deeply($e->trace, $trace, "Got the trace info"); ok(!@$events, "No events yet"); $e = $ctx->send_event('Ok', pass => 1, name => 'foo'); is($e->pass, 1, "Pass"); is($e->name, 'foo', "got name"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->ok(1, 'foo'); is($e->pass, 1, "Pass"); is($e->name, 'foo', "got name"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->note('foo'); is($e->message, 'foo', "got message"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->diag('foo'); is($e->message, 'foo', "got message"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->plan(100); is($e->max, 100, "got max"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->skip('foo', 'because'); is($e->name, 'foo', "got name"); is($e->reason, 'because', "got reason"); ok($e->pass, "skip events pass by default"); is_deeply($e->trace, $trace, "Got the trace info"); is(@$events, 1, "1 event"); is_deeply($events, [$e], "Hub saw the event"); pop @$events; $e = $ctx->skip('foo', 'because', pass => 0); ok(!$e->pass, "can override skip params"); pop @$events; # Test hooks my @hooks; $hub = test2_stack()->top; my $ref1 = $hub->add_context_init(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'hub_init' }); my $ref2 = $hub->add_context_release(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'hub_release' }); test2_add_callback_context_init(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'global_init' }); test2_add_callback_context_release(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'global_release' }); my $ref3 = $hub->add_context_aquire(sub { die "Bad Arg" unless ref($_[0]) eq 'HASH'; push @hooks => 'hub_aquire' }); test2_add_callback_context_aquire(sub { die "Bad Arg" unless ref($_[0]) eq 'HASH'; push @hooks => 'global_aquire' }); 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_aquire($ref3); @{Test2::API::_context_init_callbacks_ref()} = (); @{Test2::API::_context_release_callbacks_ref()} = (); @{Test2::API::_context_aquire_callbacks_ref()} = (); is_deeply( \@hooks, [qw{ start global_aquire hub_aquire global_init hub_init ctx_init deep global_aquire hub_aquire release_deep release_parent ctx_release_deep ctx_release hub_release global_release released_all new global_aquire hub_aquire global_init hub_init ctx_init2 release_new ctx_release2 hub_release global_release done }], "Got all hook in correct order" ); { my $ctx = context(level => -1); my $one = Test2::API::Context->new( trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'blah']), hub => test2_stack()->top, ); is($one->_depth, 0, "default depth"); my $ran = 0; my $doit = sub { is_deeply(\@_, [qw/foo bar/], "got args"); $ran++; die "Make sure old context is restored"; }; eval { $one->do_in_context($doit, 'foo', 'bar') }; my $spawn = context(level => -1, wrapped => -2); is($spawn->trace, $ctx->trace, "Old context restored"); $spawn->release; $ctx->release; ok(!exception { $one->do_in_context(sub {1}) }, "do_in_context works without an original") } { like(exception { Test2::API::Context->new() }, qr/The 'trace' attribute is required/, "need to have trace"); my $trace = Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']); like(exception { Test2::API::Context->new(trace => $trace) }, qr/The 'hub' attribute is required/, "need to have hub"); my $hub = test2_stack()->top; my $ctx = Test2::API::Context->new(trace => $trace, hub => $hub); is($ctx->{_depth}, 0, "depth set to 0 when not defined."); $ctx = Test2::API::Context->new(trace => $trace, hub => $hub, _depth => 1); is($ctx->{_depth}, 1, "Do not reset depth"); like( exception { $ctx->release }, qr/release\(\) should not be called on context that is neither canon nor a child/, "Non canonical context, do not release" ); } sub { like( exception { my $ctx = context(level => 20) }, qr/Could not find context at depth 21/, "Level sanity" ); ok( !exception { my $ctx = context(level => 20, fudge => 1); $ctx->release; }, "Was able to get context when fudging level" ); }->(); sub { my ($ctx1, $ctx2); sub { $ctx1 = context() }->(); my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; $ctx2 = context(); $ctx1 = undef; } $ctx2->release; is(@warnings, 1, "1 warning"); like( $warnings[0], qr/^context\(\) was called to retrieve an existing context, however the existing/, "Got expected warning" ); }->(); sub { my $ctx = context(); my $e = exception { $ctx->throw('xxx') }; like($e, qr/xxx/, "got exception"); $ctx = context(); my $warnings = warnings { $ctx->alert('xxx') }; like($warnings->[0], qr/xxx/, "got warning"); $ctx->release; }->(); sub { my $ctx = context; is($ctx->_parse_event('Ok'), 'Test2::Event::Ok', "Got the Ok event class"); is($ctx->_parse_event('+Test2::Event::Ok'), 'Test2::Event::Ok', "Got the +Ok event class"); like( exception { $ctx->_parse_event('+DFASGFSDFGSDGSD') }, qr/Could not load event module 'DFASGFSDFGSDGSD': Can't locate DFASGFSDFGSDGSD\.pm/, "Bad event type" ); }->(); { 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"); } sub { local $! = 100; local $@ = 'foobarbaz'; local $? = 123; my $ctx = context(); is($ctx->errno, 100, "saved errno"); is($ctx->eval_error, 'foobarbaz', "saved eval error"); is($ctx->child_error, 123, "saved child exit"); $! = 22; $@ = 'xyz'; $? = 33; is(0 + $!, 22, "altered \$! in tool"); is($@, 'xyz', "altered \$@ in tool"); is($?, 33, "altered \$? in tool"); sub { my $ctx2 = context(); $! = 42; $@ = 'app'; $? = 43; is(0 + $!, 42, "altered \$! in tool (nested)"); is($@, 'app', "altered \$@ in tool (nested)"); is($?, 43, "altered \$? in tool (nested)"); $ctx2->release; is(0 + $!, 22, "restored the nested \$! in tool"); is($@, 'xyz', "restored the nested \$@ in tool"); is($?, 33, "restored the nested \$? in tool"); }->(); sub { my $ctx2 = context(); $! = 42; $@ = 'app'; $? = 43; is(0 + $!, 42, "altered \$! in tool (nested)"); is($@, 'app', "altered \$@ in tool (nested)"); is($?, 43, "altered \$? in tool (nested)"); # Will not warn since $@ is changed $ctx2 = undef; is(0 + $!, 42, 'Destroy does not reset $!'); is($@, 'app', 'Destroy does not reset $@'); is($?, 43, 'Destroy does not reset $?'); }->(); $ctx->release; is($ctx->errno, 100, "restored errno"); is($ctx->eval_error, 'foobarbaz', "restored eval error"); is($ctx->child_error, 123, "restored child exit"); }->(); sub { local $! = 100; local $@ = 'foobarbaz'; local $? = 123; my $ctx = context(); is($ctx->errno, 100, "saved errno"); is($ctx->eval_error, 'foobarbaz', "saved eval error"); is($ctx->child_error, 123, "saved child exit"); $! = 22; $@ = 'xyz'; $? = 33; is(0 + $!, 22, "altered \$! in tool"); is($@, 'xyz', "altered \$@ in tool"); is($?, 33, "altered \$? in tool"); # Will not warn since $@ is changed $ctx = undef; is(0 + $!, 22, "Destroy does not restore \$!"); is($@, 'xyz', "Destroy does not restore \$@"); is($?, 33, "Destroy does not restore \$?"); }->(); done_testing; Hub000755001750001750 012654206301 15467 5ustar00exodistexodist000000000000Test2-0.000025/lib/Test2Subtest.pm100644001750001750 232712654206301 17622 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Hubpackage Test2::Hub::Subtest; use strict; use warnings; use base 'Test2::Hub'; use Test2::Util::HashBase qw/nested bailed_out exit_code/; sub process { my $self = shift; my ($e) = @_; $e->set_nested($self->nested); $self->set_bailed_out($e) if $e->isa('Test2::Event::Bail'); $self->SUPER::process($e); } sub terminate { my $self = shift; my ($code) = @_; $self->set_exit_code($code); no warnings 'exiting'; last T2_SUBTEST_WRAPPER; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Hub::Subtest - Hub used by subtests =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 DESCRIPTION Subtests make use of this hub to route events. =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 2015 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 Context.pm100644001750001750 4675312654206301 17543 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/APIpackage Test2::API::Context; use strict; use warnings; use Carp qw/confess croak longmess/; use Scalar::Util qw/weaken/; use Test2::Util qw/get_tid try pkg_to_file get_tid/; use Test2::Util::Trace(); use Test2::API(); # Preload some key event types my %LOADED = ( map { my $pkg = "Test2::Event::$_"; my $file = "Test2/Event/$_.pm"; require $file unless $INC{$file}; ( $pkg => $pkg, $_ => $pkg ) } qw/Ok Diag Note Plan Bail Exception Waiting Skip Subtest/ ); use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; use Test2::Util::HashBase qw{ stack hub trace _on_release _depth _is_canon _is_spawn _aborted errno eval_error child_error }; # Private, not package vars # It is safe to cache these. my $ON_RELEASE = Test2::API::_context_release_callbacks_ref(); my $CONTEXTS = Test2::API::_contexts_ref(); sub init { my $self = shift; confess "The 'trace' attribute is required" unless $self->{+TRACE}; confess "The 'hub' attribute is required" unless $self->{+HUB}; $self->{+_DEPTH} = 0 unless defined $self->{+_DEPTH}; $self->{+ERRNO} = $! unless exists $self->{+ERRNO}; $self->{+EVAL_ERROR} = $@ unless exists $self->{+EVAL_ERROR}; $self->{+CHILD_ERROR} = $? unless exists $self->{+CHILD_ERROR}; } sub snapshot { bless {%{$_[0]}, _is_canon => undef, _is_spawn => undef, _aborted => undef}, __PACKAGE__ } sub restore_error_vars { my $self = shift; ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; } sub DESTROY { return unless $_[0]->{+_IS_CANON} || $_[0]->{+_IS_SPAWN}; return if $_[0]->{+_ABORTED} && ${$_[0]->{+_ABORTED}}; my ($self) = @_; my $hub = $self->{+HUB}; my $hid = $hub->{hid}; # Do not show the warning if it looks like an exception has been thrown, or # if the context is not local to this process or thread. if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) { my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame; warn <<" EOT"; A context appears to have been destroyed without first calling release(). Based on \$@ it does not look like an exception was thrown (this is not always a reliable test) This is a problem because the global error variables (\$!, \$@, and \$?) will not be restored. In addition some release callbacks will not work properly from inside a DESTROY method. Here are the context creation details, just in case a tool forgot to call release(): File: $frame->[1] Line: $frame->[2] Tool: $frame->[3] Cleaning up the CONTEXT stack... EOT } return if $self->{+_IS_SPAWN}; # Remove the key itself to avoid a slow memory leak delete $CONTEXTS->{$hid}; $self->{+_IS_CANON} = undef; if (my $cbk = $self->{+_ON_RELEASE}) { $_->($self) for reverse @$cbk; } if (my $hcbk = $hub->{_context_release}) { $_->($self) for reverse @$hcbk; } $_->($self) for reverse @$ON_RELEASE; } # release exists to implement behaviors like die-on-fail. In die-on-fail you # want to die after a failure, but only after diagnostics have been reported. # The ideal time for the die to happen is when the context is released. # Unfortunately die does not work in a DESTROY block. sub release { my ($self) = @_; ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return $self->{+_IS_SPAWN} = undef if $self->{+_IS_SPAWN}; croak "release() should not be called on context that is neither canon nor a child" unless $self->{+_IS_CANON}; my $hub = $self->{+HUB}; my $hid = $hub->{hid}; croak "context thinks it is canon, but it is not" unless $CONTEXTS->{$hid} && $CONTEXTS->{$hid} == $self; # Remove the key itself to avoid a slow memory leak $self->{+_IS_CANON} = undef; delete $CONTEXTS->{$hid}; if (my $cbk = $self->{+_ON_RELEASE}) { $_->($self) for reverse @$cbk; } if (my $hcbk = $hub->{_context_release}) { $_->($self) for reverse @$hcbk; } $_->($self) for reverse @$ON_RELEASE; # Do this last so that nothing else changes them. # If one of the hooks dies then these do not get restored, this is # intentional ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; return; } sub do_in_context { my $self = shift; my ($sub, @args) = @_; # We need to update the pid/tid and error vars. my $clone = $self->snapshot; @$clone{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} = ($!, $@, $?); $clone->{+TRACE} = $clone->{+TRACE}->snapshot; $clone->{+TRACE}->set_pid($$); $clone->{+TRACE}->set_tid(get_tid()); my $hub = $clone->{+HUB}; my $hid = $hub->hid; my $old = $CONTEXTS->{$hid}; $clone->{+_IS_CANON} = 1; $CONTEXTS->{$hid} = $clone; weaken($CONTEXTS->{$hid}); my ($ok, $err) = &try($sub, @args); my ($rok, $rerr) = try { $clone->release }; delete $clone->{+_IS_CANON}; if ($old) { $CONTEXTS->{$hid} = $old; weaken($CONTEXTS->{$hid}); } else { delete $CONTEXTS->{$hid}; } die $err unless $ok; die $rerr unless $rok; } sub done_testing { my $self = shift; $self->hub->finalize($self->trace, 1); return; } sub throw { my ($self, $msg) = @_; ${$self->{+_ABORTED}}++ if $self->{+_ABORTED}; $self->release if $self->{+_IS_CANON} || $self->{+_IS_SPAWN}; $self->trace->throw($msg); } sub alert { my ($self, $msg) = @_; $self->trace->alert($msg); } sub send_event { my $self = shift; my $event = shift; my %args = @_; my $pkg = $LOADED{$event} || $self->_parse_event($event); $self->{+HUB}->send( $pkg->new( trace => $self->{+TRACE}->snapshot, %args, ) ); } sub build_event { my $self = shift; my $event = shift; my %args = @_; my $pkg = $LOADED{$event} || $self->_parse_event($event); $pkg->new( trace => $self->{+TRACE}->snapshot, %args, ); } sub ok { my $self = shift; my ($pass, $name, $diag) = @_; my $hub = $self->{+HUB}; my $e = bless { trace => bless( {%{$self->{+TRACE}}}, 'Test2::Util::Trace'), pass => $pass, name => $name, }, 'Test2::Event::Ok'; $e->init; $hub->send($e); return $e if $pass; $self->failure_diag($e); if ($diag && @$diag) { $self->diag($_) for @$diag } return $e; } sub failure_diag { my $self = shift; my ($e) = @_; # This behavior is inherited from Test::Builder which injected a newline at # the start of the first diagnostics when the harness is active, but not # verbose. This is important to keep the diagnostics from showing up # appended to the existing line, which is hard to read. In a verbose # harness there is no need for this. my $prefix = $ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_IS_VERBOSE} ? "\n" : ""; # Figure out the debug info, this is typically the file name and line # number, but can also be a custom message. If no trace object is provided # then we have nothing useful to display. my $name = $e->name; my $trace = $e->trace; my $debug = $trace ? $trace->debug : "[No trace info available]"; # Create the initial diagnostics. If the test has a name we put the debug # info on a second line, this behavior is inherited from Test::Builder. my $msg = defined($name) ? qq[${prefix}Failed test '$name'\n$debug.\n] : qq[${prefix}Failed test $debug.\n]; $self->diag($msg); } sub skip { my $self = shift; my ($name, $reason, @extra) = @_; $self->send_event( 'Skip', name => $name, reason => $reason, pass => 1, @extra, ); } sub note { my $self = shift; my ($message) = @_; $self->send_event('Note', message => $message); } sub diag { my $self = shift; my ($message) = @_; my $hub = $self->{+HUB}; $self->send_event( 'Diag', message => $message, ); } sub plan { my ($self, $max, $directive, $reason) = @_; ${$self->{+_ABORTED}}++ if $self->{+_ABORTED} && $directive && $directive =~ m/^(SKIP|skip_all)$/; $self->send_event('Plan', max => $max, directive => $directive, reason => $reason); } sub bail { my ($self, $reason) = @_; ${$self->{+_ABORTED}}++ if $self->{+_ABORTED}; $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 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 DESCRIPTION The context object is the primary interface for authors of testing tools written with L. The context object represents the context in which a test takes place (File and Line Number), and provides a quick way to generate events from that context. The context object also takes care of sending events to the correct L instance. =head1 SYNOPSIS In general you will not be creating contexts directly. To obtain a context you should always use C which is exported by the L module. use Test2::API qw/context/; sub my_ok { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; # You MUST do this! return $bool; } Context objects make it easy to wrap other tools that also use context. Once you grab a context, any tool you call before releasing your context will inherit it: sub wrapper { my ($bool, $name) = @_; my $ctx = context(); $ctx->diag("wrapping my_ok"); my $out = my_ok($bool, $name); $ctx->release; # You MUST do this! return $out; } =head1 CRITICAL DETAILS =over 4 =item you MUST always use the context() sub from Test2::API Creating your own context via C<< Test2::API::Context->new() >> will almost never produce a desirable result. Use C which is exported by L. There are a handful of cases where a tool author may want to create a new context by hand, which is why the C method exists. Unless you really know what you are doing you should avoid this. =item You MUST always release the context when done with it Releasing the context tells the system you are done with it. This gives it a chance to run any necessary callbacks or cleanup tasks. If you forget to release the context it will try to detect the problem and warn you about it. =item You MUST NOT pass context objects around When you obtain a context object it is made specifically for your tool and any tools nested within. If you pass a context around you run the risk of polluting other tools with incorrect context information. If you are certain that you want a different tool to use the same context you may pass it a snapshot. C<< $ctx->snapshot >> will give you a shallow clone of the context that is safe to pass around or store. =item You MUST NOT store or cache a context for later As long as a context exists for a given hub, all tools that try to get a context will get the existing instance. If you try to store the context you will pollute other tools with incorrect context information. If you are certain that you want to save the context for later, you can use a snapshot. C<< $ctx->snapshot >> will give you a shallow clone of the context that is safe to pass around or store. C has some mechanisms to protect you if you do cause a context to persist beyond the scope in which it was obtained. In practice you should not rely on these protections, and they are fairly noisy with warnings. =item You SHOULD obtain your context as soon as possible in a given tool You never know what tools you call from within your own tool will need a context. Obtaining the context early ensures that nested tools can find the context you want them to find. =back =head1 METHODS =over 4 =item $ctx->done_testing; Note that testing is finished. If no plan has been set this will generate a Plan event. =item $clone = $ctx->snapshot() This will return a shallow clone of the context. The shallow clone is safe to store for later. =item $ctx->release() This will release the context. This runs cleanup tasks, and several important hooks. It will also restore C<$!>, C<$?>, and C<$@> to what they were when the context was created. B If a context is aquired 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 recognises 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 TID, PID, and error vars to be correct without modifying the original context. =item $ctx->restore_error_vars() This will set C<$!>, C<$?>, and C<$@> to what they were when the context was created. There is no localization or anything done here, calling this method will actually set these vars. =item $! = $ctx->errno() The (numeric) value of C<$!> when the context was created. =item $? = $ctx->child_error() The value of C<$?> when the context was created. =item $@ = $ctx->eval_error() The value of C<$@> when the context was created. =back =head2 EVENT PRODUCTION METHODS =over 4 =item $event = $ctx->ok($bool, $name) =item $event = $ctx->ok($bool, $name, \@diag) 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 C<\@diag> can contain diagnostics messages you wish to have displayed in the event of a failure. For a passing test the diagnostics array will be ignored. =item $event = $ctx->note($message) Send an L. This event prints a message to STDOUT. =item $event = $ctx->diag($message) Send an L. This event prints a message to STDERR. =item $event = $ctx->plan($max) =item $event = $ctx->plan(0, 'SKIP', $reason) This can be used to send an L event. This event usually takes either a number of tests you expect to run. Optionally you can set the expected count to 0 and give the 'SKIP' directive with a reason to cause all tests to be skipped. =item $event = $ctx->skip($name, $reason); Send an L event. =item $event = $ctx->bail($reason) This sends an L event. This event will completely terminate all testing. =item $event = $ctx->send_event($Type, %parameters) This lets you build and send an event of any type. The C<$Type> argument should be the event package name with C left off, or a fully qualified package name prefixed with a '+'. The event is returned after it is sent. my $event = $ctx->send_event('Ok', ...); or my $event = $ctx->send_event('+Test2::Event::Ok', ...); =item $event = $ctx->build_event($Type, %parameters) This is the same as C, except it builds and returns the event without sending it. =back =head1 HOOKS There are 2 types of hooks, init hooks, and release hooks. As the names suggest, these hooks are triggered when contexts are created or released. =head2 INIT HOOKS These are called whenever a context is initialized. That means when a new instance is created. These hooks are B called every time something requests a context, just when a new one is created. =head3 GLOBAL This is how you add a global init callback. Global callbacks happen for every context for any hub or stack. Test2::API::test2_add_callback_context_init(sub { my $ctx = shift; ... }); =head3 PER HUB This is how you add an init callback for all contexts created for a given hub. These callbacks will not run for other hubs. $hub->add_context_init(sub { my $ctx = shift; ... }); =head3 PER CONTEXT This is how you specify an init hook that will only run if your call to C generates a new context. The callback will be ignored if C is returning an existing context. my $ctx = context(on_init => sub { my $ctx = shift; ... }); =head2 RELEASE HOOKS These are called whenever a context is released. That means when the last reference to the instance is about to be destroyed. These hooks are B called every time C<< $ctx->release >> is called. =head3 GLOBAL This is how you add a global release callback. Global callbacks happen for every context for any hub or stack. Test2::API::test2_add_callback_context_release(sub { my $ctx = shift; ... }); =head3 PER HUB This is how you add a release callback for all contexts created for a given hub. These callbacks will not run for other hubs. $hub->add_context_release(sub { my $ctx = shift; ... }); =head3 PER CONTEXT This is how you add release callbacks directly to a context. The callback will B be added to the context that gets returned, it does not matter if a new one is generated, or if an existing one is returned. my $ctx = context(on_release => sub { my $ctx = shift; ... }); =head1 THIRD PARTY META-DATA This object consumes L which provides a consistent way for you to attach meta-data to instances of this class. This is useful for tools, plugins, and other extentions. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =item Kent Fredric Ekentnl@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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.t100644001750001750 2507312654206301 17646 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/APIuse strict; use warnings; use Test2::IPC; BEGIN { require "t/tools.pl" }; use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK USE_THREADS get_tid/; my $CLASS = 'Test2::API::Instance'; my $one = $CLASS->new; is_deeply( $one, { pid => $$, tid => get_tid(), contexts => {}, finalized => undef, ipc => undef, formatter => undef, ipc_polling => undef, ipc_drivers => [], formatters => [], no_wait => 0, loaded => 0, exit_callbacks => [], post_load_callbacks => [], context_aquire_callbacks => [], context_init_callbacks => [], context_release_callbacks => [], stack => [], }, "Got initial settings" ); %$one = (); is_deeply($one, {}, "wiped object"); $one->reset; is_deeply( $one, { pid => $$, tid => get_tid(), contexts => {}, ipc_polling => undef, ipc_drivers => [], formatters => [], finalized => undef, ipc => undef, formatter => undef, no_wait => 0, loaded => 0, exit_callbacks => [], post_load_callbacks => [], context_aquire_callbacks => [], context_init_callbacks => [], context_release_callbacks => [], stack => [], }, "Reset Object" ); ok(!$one->formatter_set, "no formatter set"); $one->set_formatter('Foo'); ok($one->formatter_set, "formatter set"); $one->reset; my $ran = 0; my $callback = sub { $ran++ }; $one->add_post_load_callback($callback); ok(!$ran, "did not run yet"); is_deeply($one->post_load_callbacks, [$callback], "stored callback for later"); ok(!$one->loaded, "not loaded"); $one->load; ok($one->loaded, "loaded"); is($ran, 1, "ran the callback"); $one->load; is($ran, 1, "Did not run the callback again"); $one->add_post_load_callback($callback); is($ran, 2, "ran the new callback"); is_deeply($one->post_load_callbacks, [$callback, $callback], "stored callback for the record"); like( exception { $one->add_post_load_callback({}) }, qr/Post-load callbacks must be coderefs/, "Post-load callbacks must be coderefs" ); $one->reset; ok($one->ipc, 'got ipc'); ok($one->finalized, "calling ipc finalized the object"); $one->reset; ok($one->stack, 'got stack'); ok(!$one->finalized, "calling stack did not finaliz the object"); $one->reset; ok($one->formatter, 'Got formatter'); ok($one->finalized, "calling format finalized the object"); $one->reset; $one->set_formatter('Foo'); is($one->formatter, 'Foo', "got specified formatter"); ok($one->finalized, "calling format finalized the object"); { local $ENV{T2_FORMATTER} = 'TAP'; $one->reset; is($one->formatter, 'Test2::Formatter::TAP', "got specified formatter"); ok($one->finalized, "calling format finalized the object"); local $ENV{T2_FORMATTER} = '+Test2::Formatter::TAP'; $one->reset; is($one->formatter, 'Test2::Formatter::TAP', "got specified formatter"); ok($one->finalized, "calling format finalized the object"); local $ENV{T2_FORMATTER} = '+Fake'; $one->reset; like( exception { $one->formatter }, qr/COULD NOT LOAD FORMATTER 'Fake' \(set by the 'T2_FORMATTER' environment variable\)/, "Bad formatter" ); } $ran = 0; $one->reset; $one->add_exit_callback($callback); is(@{$one->exit_callbacks}, 1, "added an exit callback"); $one->add_exit_callback($callback); is(@{$one->exit_callbacks}, 2, "added another exit callback"); like( exception { $one->add_exit_callback({}) }, qr/End callbacks must be coderefs/, "Exit callbacks must be coderefs" ); if (CAN_REALLY_FORK) { $one->reset; my $pid = fork; die "Failed to fork!" unless defined $pid; unless($pid) { exit 0 } is($one->_ipc_wait, 0, "No errors"); $pid = fork; die "Failed to fork!" unless defined $pid; unless($pid) { exit 255 } my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; is($one->_ipc_wait, 255, "Process exited badly"); } like($warnings[0], qr/Process .* did not exit cleanly \(status: 255\)/, "Warn about exit"); } if (CAN_THREAD && $] ge '5.010') { require threads; $one->reset; threads->new(sub { 1 }); is($one->_ipc_wait, 0, "No errors"); if (threads->can('error')) { threads->new(sub { close(STDERR); close(STDOUT); die "xxx" }); my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; is($one->_ipc_wait, 255, "Thread exited badly"); } like($warnings[0], qr/Thread .* did not end cleanly: xxx/, "Warn about exit"); } } { $one->reset(); local $? = 0; $one->set_exit; is($?, 0, "no errors on exit"); } { $one->reset(); $one->set_tid(1); local $? = 0; $one->set_exit; is($?, 0, "no errors on exit"); } { $one->reset(); $one->stack->top; $one->no_wait(1); local $? = 0; $one->set_exit; is($?, 0, "no errors on exit"); } { $one->reset(); $one->stack->top->set_no_ending(1); local $? = 0; $one->set_exit; is($?, 0, "no errors on exit"); } { $one->reset(); $one->stack->top->set_failed(2); local $? = 0; $one->set_exit; is($?, 2, "number of failures"); } { $one->reset(); local $? = 500; $one->set_exit; is($?, 255, "set exit code to a sane number"); } { local %INC = %INC; delete $INC{'Test2/IPC.pm'}; $one->reset(); my @events; $one->stack->top->filter(sub { push @events => $_[1]; undef}); $one->stack->new_hub; local $? = 0; $one->set_exit; is($?, 255, "errors on exit"); like($events[0]->message, qr/Test ended with extra hubs on the stack!/, "got diag"); } { $one->reset(); my @events; $one->stack->top->filter(sub { push @events => $_[1]; undef}); $one->stack->new_hub; ok($one->stack->top->ipc, "Have IPC"); $one->stack->new_hub; ok($one->stack->top->ipc, "Have IPC"); $one->stack->top->set_ipc(undef); ok(!$one->stack->top->ipc, "no IPC"); $one->stack->new_hub; local $? = 0; $one->set_exit; is($?, 255, "errors on exit"); like($events[0]->message, qr/Test ended with extra hubs on the stack!/, "got diag"); } if (CAN_REALLY_FORK) { local $SIG{__WARN__} = sub { }; $one->reset(); my $pid = fork; die "Failed to fork!" unless defined $pid; unless ($pid) { exit 255 } $one->_finalize; $one->stack->top; local $? = 0; $one->set_exit; is($?, 255, "errors on exit"); $one->reset(); $pid = fork; die "Failed to fork!" unless defined $pid; unless ($pid) { exit 255 } $one->_finalize; $one->stack->top; local $? = 122; $one->set_exit; is($?, 122, "kept original exit"); } { my $ctx = bless { trace => Test2::Util::Trace->new(frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'xxx']), hub => Test2::Hub->new(), }, 'Test2::API::Context'; $one->contexts->{1234} = $ctx; local $? = 500; my $warnings = warnings { $one->set_exit }; is($?, 255, "set exit code to a sane number"); is_deeply( $warnings, [ "context object was never released! This means a testing tool is behaving very badly at Foo/Bar.pm line 42.\n" ], "Warned about unfreed context" ); } { local %INC = %INC; delete $INC{'Test2/IPC.pm'}; delete $INC{'threads.pm'}; ok(!USE_THREADS, "Sanity Check"); $one->reset; ok(!$one->ipc, 'IPC not loaded, no IPC object'); ok($one->finalized, "calling ipc finalized the object"); is($one->ipc_polling, undef, "no polling defined"); ok(!@{$one->ipc_drivers}, "no driver"); if (CAN_THREAD) { local $INC{'threads.pm'} = 1; no warnings 'once'; local *threads::tid = sub { 0 } unless threads->can('tid'); $one->reset; ok($one->ipc, 'IPC loaded if threads are'); ok($one->finalized, "calling ipc finalized the object"); ok($one->ipc_polling, "polling on by default"); is($one->ipc_drivers->[0], 'Test2::IPC::Driver::Files', "default driver"); } { local $INC{'Test2/IPC.pm'} = 1; $one->reset; ok($one->ipc, 'IPC loaded if Test2::IPC is'); ok($one->finalized, "calling ipc finalized the object"); ok($one->ipc_polling, "polling on by default"); is($one->ipc_drivers->[0], 'Test2::IPC::Driver::Files', "default driver"); } require Test2::IPC::Driver::Files; $one->reset; $one->add_ipc_driver('Test2::IPC::Driver::Files'); ok($one->ipc, 'IPC loaded if drivers have been added'); ok($one->finalized, "calling ipc finalized the object"); ok($one->ipc_polling, "polling on by default"); my $file = __FILE__; my $line = __LINE__ + 1; my $warnings = warnings { $one->add_ipc_driver('Test2::IPC::Driver::Files') }; like( $warnings->[0], qr{^IPC driver Test2::IPC::Driver::Files loaded too late to be used as the global ipc driver at \Q$file\E line $line}, "Got warning at correct frame" ); $one->reset; $one->add_ipc_driver('Fake::Fake::XXX'); is( exception { $one->ipc }, "IPC has been requested, but no viable drivers were found. Aborting...\n", "Failed without viable IPC driver" ); } { $one->reset; ok(!@{$one->context_init_callbacks}, "no callbacks"); is($one->ipc_polling, undef, "no polling, undef"); $one->disable_ipc_polling; ok(!@{$one->context_init_callbacks}, "no callbacks"); is($one->ipc_polling, undef, "no polling, still undef"); my $cull = 0; no warnings 'once'; local *Fake::Hub::cull = sub { $cull++ }; use warnings; $one->enable_ipc_polling; is(@{$one->context_init_callbacks}, 1, "added the callback"); is($one->ipc_polling, 1, "polling on"); $one->set_ipc_shm_last('abc1'); $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'}); is($cull, 1, "called cull once"); $cull = 0; $one->disable_ipc_polling; is(@{$one->context_init_callbacks}, 1, "kept the callback"); is($one->ipc_polling, 0, "no polling, set to 0"); $one->set_ipc_shm_last('abc3'); $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'}); is($cull, 0, "did not call cull"); $cull = 0; $one->enable_ipc_polling; is(@{$one->context_init_callbacks}, 1, "did not add the callback"); is($one->ipc_polling, 1, "polling on"); $one->set_ipc_shm_last('abc3'); $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'}); is($cull, 1, "called cull once"); } done_testing; Instance.pm100644001750001750 4123712654206301 17653 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/APIpackage Test2::API::Instance; use strict; use warnings; our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/; use Carp qw/confess carp/; use Scalar::Util qw/reftype/; use Test2::Util qw/get_tid USE_THREADS CAN_FORK pkg_to_file try/; use Test2::Util::Trace(); use Test2::API::Stack(); use Test2::Util::HashBase qw{ pid tid no_wait finalized loaded ipc stack formatter contexts ipc_shm_size ipc_shm_last ipc_shm_id ipc_polling ipc_drivers formatters exit_callbacks post_load_callbacks context_aquire_callbacks context_init_callbacks context_release_callbacks }; # Wrap around the getters that should call _finalize. BEGIN { for my $finalizer (IPC, FORMATTER) { my $orig = __PACKAGE__->can($finalizer); my $new = sub { my $self = shift; $self->_finalize unless $self->{+FINALIZED}; $self->$orig; }; no strict 'refs'; no warnings 'redefine'; *{$finalizer} = $new; } } sub import { my $class = shift; return unless @_; my ($ref) = @_; $$ref = $class->new; } sub init { $_[0]->reset } sub reset { my $self = shift; $self->{+PID} = $$; $self->{+TID} = get_tid(); $self->{+CONTEXTS} = {}; $self->{+IPC_DRIVERS} = []; $self->{+IPC_POLLING} = undef; $self->{+FORMATTERS} = []; $self->{+FORMATTER} = undef; $self->{+FINALIZED} = undef; $self->{+IPC} = undef; $self->{+NO_WAIT} = 0; $self->{+LOADED} = 0; $self->{+EXIT_CALLBACKS} = []; $self->{+POST_LOAD_CALLBACKS} = []; $self->{+CONTEXT_AQUIRE_CALLBACKS} = []; $self->{+CONTEXT_INIT_CALLBACKS} = []; $self->{+CONTEXT_RELEASE_CALLBACKS} = []; $self->{+STACK} = Test2::API::Stack->new; } sub _finalize { my $self = shift; my ($caller) = @_; $caller ||= [caller(1)]; $self->{+FINALIZED} = $caller; unless ($self->{+FORMATTER}) { my ($formatter, $source); if ($ENV{T2_FORMATTER}) { $formatter = $ENV{T2_FORMATTER}; $source = "set by the 'T2_FORMATTER' environment variable"; $formatter = "Test2::Formatter::$formatter" unless $formatter =~ s/^\+//; } 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 reigstered, or the Test2::IPC # module is loaded. return unless USE_THREADS || $INC{'Test2/IPC.pm'} || @{$self->{+IPC_DRIVERS}}; # Turn on polling by default, people expect it. $self->enable_ipc_polling; unless (@{$self->{+IPC_DRIVERS}}) { my ($ok, $error) = try { require Test2::IPC::Driver::Files }; die $error unless $ok; push @{$self->{+IPC_DRIVERS}} => 'Test2::IPC::Driver::Files'; } for my $driver (@{$self->{+IPC_DRIVERS}}) { next unless $driver->can('is_viable') && $driver->is_viable; $self->{+IPC} = $driver->new or next; $self->ipc_enable_shm if $self->{+IPC}->use_shm; return; } die "IPC has been requested, but no viable drivers were found. Aborting...\n"; } sub formatter_set { $_[0]->{+FORMATTER} ? 1 : 0 } sub add_formatter { my $self = shift; my ($formatter) = @_; unshift @{$self->{+FORMATTERS}} => $formatter; return unless $self->{+FINALIZED}; # Why is the @CARP_NOT entry not enough? local %Carp::Internal = %Carp::Internal; $Carp::Internal{'Test2::Formatter'} = 1; carp "Formatter $formatter loaded too late to be used as the global formatter"; } sub add_context_aquire_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Context-aquire callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+CONTEXT_AQUIRE_CALLBACKS}} => $code; } sub add_context_init_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Context-init callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+CONTEXT_INIT_CALLBACKS}} => $code; } sub add_context_release_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Context-release callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+CONTEXT_RELEASE_CALLBACKS}} => $code; } sub add_post_load_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Post-load callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+POST_LOAD_CALLBACKS}} => $code; $code->() if $self->{+LOADED}; } sub load { my $self = shift; unless ($self->{+LOADED}) { $self->{+LOADED} = 1; $_->() for @{$self->{+POST_LOAD_CALLBACKS}}; } return $self->{+LOADED}; } sub add_exit_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "End callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+EXIT_CALLBACKS}} => $code; } sub add_ipc_driver { my $self = shift; my ($driver) = @_; unshift @{$self->{+IPC_DRIVERS}} => $driver; return unless $self->{+FINALIZED}; # Why is the @CARP_NOT entry not enough? local %Carp::Internal = %Carp::Internal; $Carp::Internal{'Test2::IPC::Driver'} = 1; carp "IPC driver $driver loaded too late to be used as the global ipc driver"; } sub enable_ipc_polling { my $self = shift; $self->add_context_init_callback( # This is called every time a context is created, it needs to be fast. # $_[0] is a context object sub { return unless $self->{+IPC_POLLING}; return $_[0]->{hub}->cull unless $self->{+IPC_SHM_ID}; my $val; { shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return; return if $val eq $self->{+IPC_SHM_LAST}; $self->{+IPC_SHM_LAST} = $val; } $_[0]->{hub}->cull; } ) unless defined $self->ipc_polling; $self->set_ipc_polling(1); } sub ipc_enable_shm { my $self = shift; return 1 if defined $self->{+IPC_SHM_ID}; my ($ok, $err) = try { require IPC::SysV; my $ipc_key = IPC::SysV::IPC_PRIVATE(); my $shm_size = $self->{+IPC}->can('shm_size') ? $self->{+IPC}->shm_size : 64; my $shm_id = shmget($ipc_key, $shm_size, 0666) or die; my $initial = 'a' x $shm_size; shmwrite($shm_id, $initial, 0, $shm_size) or die; $self->{+IPC_SHM_SIZE} = $shm_size; $self->{+IPC_SHM_ID} = $shm_id; $self->{+IPC_SHM_LAST} = $initial; }; return $ok; } sub get_ipc_pending { my $self = shift; return -1 unless defined $self->{+IPC_SHM_ID}; my $val; shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return -1; return 0 if $val eq $self->{+IPC_SHM_LAST}; $self->{+IPC_SHM_LAST} = $val; return 1; } sub set_ipc_pending { my $self = shift; return undef unless defined $self->{+IPC_SHM_ID}; my ($val) = @_; confess "value is required for set_ipc_pending" unless $val; shmwrite($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}); } sub disable_ipc_polling { my $self = shift; return unless defined $self->{+IPC_POLLING}; $self->{+IPC_POLLING} = 0; } sub _ipc_wait { my $fail = 0; while (CAN_FORK) { my $pid = CORE::wait(); my $err = $?; last if $pid == -1; next unless $err; $fail++; $err = $err >> 8; warn "Process $pid did not exit cleanly (status: $err)\n"; } if (USE_THREADS) { for my $t (threads->list()) { $t->join; # In older threads we cannot check if a thread had an error unless # we control it and its return. my $err = $t->can('error') ? $t->error : undef; next unless $err; my $tid = $t->tid(); $fail++; chomp($err); warn "Thread $tid did not end cleanly: $err\n"; } } return 0 unless $fail; return 255; } sub set_exit { my $self = shift; my $exit = $?; my $new_exit = $exit; 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 == $$; # 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 ($self->{+PID} != $$ or $self->{+TID} != get_tid()) { $? = $exit; return; } my @hubs = $self->{+STACK} ? $self->{+STACK}->all : (); if (@hubs and $self->{+IPC} and !$self->{+NO_WAIT}) { local $?; my %seen; for my $hub (reverse @hubs) { my $ipc = $hub->ipc or next; next if $seen{$ipc}++; $ipc->waiting(); } my $ipc_exit = _ipc_wait(); $new_exit ||= $ipc_exit; } # None of this is necessary if we never got a root hub if(my $root = shift @hubs) { my $trace = Test2::Util::Trace->new( frame => [__PACKAGE__, __FILE__, 0, __PACKAGE__ . '::END'], detail => __PACKAGE__ . ' END Block finalization', ); my $ctx = Test2::API::Context->new( trace => $trace, hub => $root, ); if (@hubs) { $ctx->diag("Test ended with extra hubs on the stack!"); $new_exit = 255; } unless ($root->no_ending) { local $?; $root->finalize($trace) unless $root->ended; $_->($ctx, $exit, \$new_exit) for @{$self->{+EXIT_CALLBACKS}}; $new_exit ||= $root->failed; } } $new_exit = 255 if $new_exit > 255; $? = $new_exit; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::Instance - Object used by Test2::API under the hood =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =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 immedietly 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_aquire_callbacks Get all context aquire callbacks. =item $arrayref = $obj->context_init_callbacks Get all context init callbacks. =item $arrayref = $obj->context_release_callbacks Get all context release callbacks. =item $obj->add_context_init_callback(sub { ... }) Add a context init callback. Subs are called every time a context is created. Subs get the newly created context as their only argument. =item $obj->add_context_release_callback(sub { ... }) Add a context release callback. Subs are called every time a context is released. Subs get the released context as their only argument. These callbacks should not call release on the context. =item $obj->set_exit() This is intended to be called in an C block. This will look at test state and set $?. This will also call any end callbacks, and wait on child processes/threads. =item $obj->ipc_enable_shm() Turn on SHM for IPC (if possible) =item $shm_id = $obj->ipc_shm_id() If SHM is enabled for IPC this will be the shm_id for it. =item $shm_size = $obj->ipc_shm_size() If SHM is enabled for IPC this will be the size of it. =item $shm_last_val = $obj->ipc_shm_last() If SHM is enabled for IPC this will return the last SHM value seen. =item $obj->set_ipc_pending($val) use the IPC SHM to tell other processes and threads there is a pending event. C<$val> should be a unique value no other thread/process will generate. B This will also make the current process see a pending event. It does not set C, this is important because doing so could hide a previous change. =item $pending = $obj->get_ipc_pending() This returns -1 if SHM is not enabled for IPC. This returns 0 if the SHM value matches the last known value, which means there are no pending events. This returns 1 if the SHM value has changed, which means there are probably pending events. When 1 is returned this will set C<< $obj->ipc_shm_last() >>. =item $drivers = $obj->ipc_drivers Get the list of IPC drivers. =item $obj->add_ipc_driver($DRIVER_CLASS) Add an IPC driver to the list. The most recently added IPC driver will become the global one during initialization. If a driver is added after initialization has occured a warning will be generated: "IPC driver $driver loaded too late to be used as the global ipc driver" =item $bool = $obj->ipc_polling Check if polling is enabled. =item $obj->enable_ipc_polling Turn on polling. This will cull events from other processes and threads every time a context is created. =item $obj->disable_ipc_polling Turn off IPC polling. =item $bool = $obj->no_wait =item $bool = $obj->set_no_wait($bool) Get/Set no_wait. This option is used to turn off process/thread waiting at exit. =item $arrayref = $obj->exit_callbacks Get the exit callbacks. =item $obj->add_exit_callback(sub { ... }) Add an exit callback. This callback will be called by C. =item $bool = $obj->finalized Check if the object is finalized. Finalization happens when either C, C, or C are called on the object. Once finalization happens these fields are considered unchangeable (not enforced here, enforced by L). =item $ipc = $obj->ipc Get the one true IPC instance. =item $stack = $obj->stack Get the one true hub stack. =item $formatter = $obj->formatter Get the global formatter. By default this is the C<'Test2::Formatter::TAP'> package. This could be any package that implements the C method. This can also be an instantiated object. =item $bool = $obj->formatter_set() Check if a formatter has been set. =item $obj->add_formatter($class) =item $obj->add_formatter($obj) Add a formatter. The most recently added formatter will become the global one during initialization. If a formatter is added after initialization has occured a warning will be generated: "Formatter $formatter loaded too late to be used as the global formatter" =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 HashBase.t100644001750001750 426612654206301 20045 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/Utiluse strict; use warnings; BEGIN { require "t/tools.pl" }; BEGIN { $INC{'My/HBase.pm'} = __FILE__; package My::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 My::HBaseSub; use base 'My::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 = My::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 My::Const::Test; use Test2::Util::HashBase qw/foo/; sub do_it { if (FOO()) { return 'const'; } return 'not const' } } my $pkg = 'My::Const::Test'; is($pkg->do_it, 'const', "worked as expected"); { local $SIG{__WARN__} = sub { }; *My::Const::Test::FOO = sub { 0 }; } ok(!$pkg->FOO, "overrode const sub"); is($pkg->do_it, 'const', "worked as expected, const was constant"); BEGIN { $INC{'My/HBase/Wrapped.pm'} = __FILE__; package My::HBase::Wrapped; use Test2::Util::HashBase qw/foo bar/; my $foo = __PACKAGE__->can('foo'); no warnings 'redefine'; *foo = sub { my $self = shift; $self->set_bar(1); $self->$foo(@_); }; } BEGIN { $INC{'My/HBase/Wrapped/Inherit.pm'} = __FILE__; package My::HBase::Wrapped::Inherit; use base 'My::HBase::Wrapped'; use Test2::Util::HashBase; } my $o = My::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"); done_testing; Subtest.t100644001750001750 70312654206301 20134 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/Eventuse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::Event::Subtest; my $st = 'Test2::Event::Subtest'; my $trace = Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'xxx']); my $one = $st->new( trace => $trace, pass => 1, buffered => 1, name => 'foo', ); ok($one->isa('Test2::Event::Ok'), "Inherit from Ok"); is_deeply($one->subevents, [], "subevents is an arrayref"); done_testing; Waiting.t100644001750001750 36312654206301 20107 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/Eventuse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::Event::Waiting; my $waiting = Test2::Event::Waiting->new( trace => 'fake', ); ok($waiting, "Created event"); ok($waiting->global, "waiting is global"); done_testing; Formatter000755001750001750 012654206301 17060 5ustar00exodistexodist000000000000Test2-0.000025/t/modulesTAP.t100644001750001750 2556712654206301 20070 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/Formatteruse strict; use warnings; use Test2::Formatter::TAP; use Test2::API qw/context/; use PerlIO; BEGIN { require "t/tools.pl"; *OUT_STD = Test2::Formatter::TAP->can('OUT_STD') or die; *OUT_ERR = Test2::Formatter::TAP->can('OUT_ERR') or die; } use Test2::API; Test2::API::test2_add_callback_context_release(sub { my $ctx = shift; return if $ctx->hub->is_passing; $ctx->throw("(Die On Fail)"); }); ok(my $one = Test2::Formatter::TAP->new, "Created a new instance"); my $handles = $one->handles; is(@$handles, 2, "Got 2 handles"); ok($handles->[0] != $handles->[1], "First and second handles are not the same"); my $layers = { map {$_ => 1} PerlIO::get_layers($handles->[0]) }; if (${^UNICODE} & 2) { # 2 means STDIN ok($layers->{utf8}, "'S' is set in PERL_UNICODE, or in -C, honor it, utf8 should be on") } else { ok(!$layers->{utf8}, "Not utf8 by default") } $one->encoding('utf8'); is($one->encoding, 'utf8', "Got encoding"); $handles = $one->handles; is(@$handles, 2, "Got 2 handles"); $layers = { map {$_ => 1} PerlIO::get_layers($handles->[0]) }; ok($layers->{utf8}, "Now utf8"); my $two = Test2::Formatter::TAP->new(encoding => 'utf8'); $handles = $two->handles; is(@$handles, 2, "Got 2 handles"); $layers = { map {$_ => 1} PerlIO::get_layers($handles->[0]) }; ok($layers->{utf8}, "Now utf8"); { package My::Event; use base 'Test2::Event'; use Test2::Util::HashBase qw{pass name diag note}; Test2::Formatter::TAP->register_event( __PACKAGE__, sub { my $self = shift; my ($e, $num) = @_; return ( [main::OUT_STD, "ok $num - " . $e->name . "\n"], [main::OUT_ERR, "# " . $e->name . " " . $e->diag . "\n"], [main::OUT_STD, "# " . $e->name . " " . $e->note . "\n"], ); } ); } my ($std, $err); open( my $stdh, '>', \$std ) || die "Ooops"; open( my $errh, '>', \$err ) || die "Ooops"; my $it = Test2::Formatter::TAP->new( handles => [$stdh, $errh, $stdh], ); $it->write( My::Event->new( pass => 1, name => 'foo', diag => 'diag', note => 'note', trace => 'fake', ), 55, ); $it->write( My::Event->new( pass => 1, name => 'bar', diag => 'diag', note => 'note', trace => 'fake', nested => 1, ), 1, ); is($std, <new; sub before_each { # Make sure there is a fresh trace object for each group $trace = Test2::Util::Trace->new( frame => ['main_foo', 'foo.t', 42, 'main_foo::flubnarb'], ); } tests bail => sub { my $bail = Test2::Event::Bail->new( trace => $trace, reason => 'evil', ); is_deeply( [$fmt->event_tap($bail, 1)], [[OUT_STD, "Bail out! evil\n" ]], "Got tap" ); }; tests diag => sub { my $diag = Test2::Event::Diag->new( trace => $trace, message => 'foo', ); is_deeply( [$fmt->event_tap($diag, 1)], [[OUT_ERR, "# foo\n"]], "Got tap" ); $diag->set_message("foo\n"); is_deeply( [$fmt->event_tap($diag, 1)], [[OUT_ERR, "# foo\n"]], "Only 1 newline" ); $diag->set_message("foo\nbar\nbaz"); is_deeply( [$fmt->event_tap($diag, 1)], [[OUT_ERR, "# foo\n# bar\n# baz\n"]], "All lines have proper prefix" ); }; tests exception => sub { my $exception = Test2::Event::Exception->new( trace => $trace, error => "evil at lake_of_fire.t line 6\n", ); is_deeply( [$fmt->event_tap($exception, 1)], [[OUT_ERR, "evil at lake_of_fire.t line 6\n" ]], "Got tap" ); }; tests note => sub { my $note = Test2::Event::Note->new( trace => $trace, message => 'foo', ); is_deeply( [$fmt->event_tap($note, 1)], [[OUT_STD, "# foo\n"]], "Got tap" ); $note->set_message("foo\n"); is_deeply( [$fmt->event_tap($note, 1)], [[OUT_STD, "# foo\n"]], "Only 1 newline" ); $note->set_message("foo\nbar\nbaz"); is_deeply( [$fmt->event_tap($note, 1)], [[OUT_STD, "# foo\n# bar\n# baz\n"]], "All lines have proper prefix" ); }; for my $pass (1, 0) { local $ENV{HARNESS_IS_VERBOSE} = 1; tests name_and_number => sub { my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass, name => 'foo'); my @tap = $fmt->event_tap($ok, 7); is_deeply( \@tap, [ [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7 - foo\n"], ], "Got expected output" ); }; tests no_number => sub { my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass, name => 'foo'); my @tap = $fmt->event_tap($ok, ); is_deeply( \@tap, [ [OUT_STD, ($pass ? 'ok' : 'not ok') . " - foo\n"], ], "Got expected output" ); }; tests no_name => sub { my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass); my @tap = $fmt->event_tap($ok, 7); is_deeply( \@tap, [ [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7\n"], ], "Got expected output" ); }; tests todo => sub { my $ok = Test2::Event::Ok->new(trace => $trace, pass => $pass); $ok->set_todo('b'); my @tap = $fmt->event_tap($ok, 7); is_deeply( \@tap, [ [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7 # TODO b\n"], ], "Got expected output" ); $ok->set_todo(""); @tap = $fmt->event_tap($ok, 7); is_deeply( \@tap, [ [OUT_STD, ($pass ? 'ok' : 'not ok') . " 7 # TODO\n"], ], "Got expected output" ); }; }; tests plan => sub { my $plan = Test2::Event::Plan->new( trace => $trace, max => 100, ); is_deeply( [$fmt->event_tap($plan, 1)], [[OUT_STD, "1..100\n"]], "Got tap" ); $plan->set_max(0); $plan->set_directive('SKIP'); $plan->set_reason('foo'); is_deeply( [$fmt->event_tap($plan, 1)], [[OUT_STD, "1..0 # SKIP foo\n"]], "Got tap for skip_all" ); $plan = Test2::Event::Plan->new( trace => $trace, max => 0, directive => 'skip_all', ); is_deeply( [$fmt->event_tap($plan)], [[OUT_STD, "1..0 # SKIP\n"]], "SKIP without reason" ); $plan = Test2::Event::Plan->new( trace => $trace, max => 0, directive => 'no_plan', ); is_deeply( [$fmt->event_tap($plan)], [], "NO PLAN" ); $plan = Test2::Event::Plan->new( trace => $trace, max => 0, directive => 'skip_all', reason => "Foo\nBar\nBaz", ); is_deeply( [$fmt->event_tap($plan)], [ [OUT_STD, "1..0 # SKIP Foo\n# Bar\n# Baz\n"], ], "Multi-line reason for skip" ); }; tests subtest => sub { my $st = 'Test2::Event::Subtest'; my $one = $st->new( trace => $trace, pass => 1, buffered => 1, name => 'foo', ); is_deeply( [$fmt->event_tap($one, 5)], [ [OUT_STD, "ok 5 - foo {\n"], [OUT_STD, "}\n"], ], "Got Buffered TAP output" ); $one->set_buffered(0); is_deeply( [$fmt->event_tap($one, 5)], [ [OUT_STD, "ok 5 - foo\n"], ], "Got Unbuffered TAP output" ); $one = $st->new( trace => $trace, pass => 0, buffered => 1, name => 'bar', subevents => [ Test2::Event::Ok->new(trace => $trace, name => 'first', pass => 1), Test2::Event::Ok->new(trace => $trace, name => 'second', pass => 0), Test2::Event::Ok->new(trace => $trace, name => 'third', pass => 1), Test2::Event::Diag->new(trace => $trace, message => 'blah blah'), Test2::Event::Plan->new(trace => $trace, max => 3), ], ); { local $ENV{HARNESS_IS_VERBOSE}; is_deeply( [$fmt->event_tap($one, 5)], [ [OUT_STD, "not ok 5 - bar {\n"], [OUT_STD, " ok 1 - first\n"], [OUT_STD, " not ok 2 - second\n"], [OUT_STD, " ok 3 - third\n"], [OUT_ERR, " # blah blah\n"], [OUT_STD, " 1..3\n"], [OUT_STD, "}\n"], ], "Got Buffered TAP output (non-verbose)" ); } { local $ENV{HARNESS_IS_VERBOSE} = 1; is_deeply( [$fmt->event_tap($one, 5)], [ [OUT_STD, "not ok 5 - bar {\n"], [OUT_STD, " ok 1 - first\n"], [OUT_STD, " not ok 2 - second\n"], [OUT_STD, " ok 3 - third\n"], [OUT_ERR, " # blah blah\n"], [OUT_STD, " 1..3\n"], [OUT_STD, "}\n"], ], "Got Buffered TAP output (verbose)" ); } { local $ENV{HARNESS_IS_VERBOSE}; $one->set_buffered(0); is_deeply( [$fmt->event_tap($one, 5)], [ # In unbuffered TAP the subevents are rendered outside of this. [OUT_STD, "not ok 5 - bar\n"], ], "Got Unbuffered TAP output (non-verbose)" ); } { local $ENV{HARNESS_IS_VERBOSE} = 1; $one->set_buffered(0); is_deeply( [$fmt->event_tap($one, 5)], [ # In unbuffered TAP the subevents are rendered outside of this. [OUT_STD, "not ok 5 - bar\n"], ], "Got Unbuffered TAP output (verbose)" ); } }; tests skip => sub { my $skip = Test2::Event::Skip->new(trace => $trace, pass => 1, name => 'foo', reason => 'xxx'); my @tap = $fmt->event_tap($skip, 7); is_deeply( \@tap, [ [OUT_STD, "ok 7 - foo # skip xxx\n"], ], "Passing Skip" ); $skip->set_pass(0); @tap = $fmt->event_tap($skip, 7); is_deeply( \@tap, [ [OUT_STD, "not ok 7 - foo # skip xxx\n"], ], "Failling Skip" ); $skip->set_todo("xxx"); @tap = $fmt->event_tap($skip, 7); is_deeply( \@tap, [ [OUT_STD, "not ok 7 - foo # TODO & SKIP xxx\n"], ], "Todo Skip" ); }; done_testing; HashBase.pm100644001750001750 1264512654206301 20072 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Utilpackage Test2::Util::HashBase; use strict; use warnings; my %ATTRS; my %META; sub _get_inherited_attrs { no strict 'refs'; my @todo = map @{"$_\::ISA"}, @_; my %seen; my @all; while (my $pkg = shift @todo) { next if $seen{$pkg}++; my $found = $META{$pkg}; push @all => %$found if $found; my $isa = \@{"$pkg\::ISA"}; push @todo => @$isa if @$isa; } return \@all; } sub _make_subs { my ($str) = @_; return $ATTRS{$str} ||= { uc($str) => sub() { $str }, $str => sub { $_[0]->{$str} }, "set_$str" => sub { $_[0]->{$str} = $_[1] }, }; } sub import { my $class = shift; my $into = caller; my %attrs = map %{_make_subs($_)}, @_; my @meta = map uc, @_; @{$META{$into}}{@meta} = map $attrs{$_}, @meta; my %subs = ( %attrs, @{_get_inherited_attrs($into)}, $into->can('new') ? () : (new => \&_new) ); no strict 'refs'; *{"$into\::$_"} = $subs{$_} for keys %subs; } sub _new { my ($class, %params) = @_; my $self = bless \%params, $class; $self->init if $self->can('init'); $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::HashBase - Base class for classes that use a hashref of a hash. =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 SYNOPSIS A class: package My::Class; use strict; use warnings; # Generate 3 accessors use Test2::Util::HashBase qw/foo bar baz/; # Chance to initialize defaults sub init { my $self = shift; # No other args $self->{+FOO} ||= "foo"; $self->{+BAR} ||= "bar"; $self->{+BAZ} ||= "baz"; } sub print { print join ", " => map { $self->{$_} } FOO, BAR, BAZ; } Subclass it package My::Subclass; use strict; use warnings; # Note, you should subclass before loading HashBase. use base 'My::Class'; use Test2::Util::HashBase qw/bat/; sub init { my $self = shift; # We get the constants from the base class for free. $self->{+FOO} ||= 'SubFoo'; $self->{+BAT} || = 'bat'; $self->SUPER::init(); } use it: package main; use strict; use warnings; use My::Class; my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar'); # Accessors! my $foo = $one->foo; # 'MyFoo' my $bar = $one->bar; # 'MyBar' my $baz = $one->baz; # Defaulted to: 'baz' # Setters! $one->set_foo('A Foo'); $one->set_bar('A Bar'); $one->set_baz('A Baz'); $one->{+FOO} = 'xxx'; =head1 DESCRIPTION This package is used to generate classes based on hashrefs. Using this class will give you a C method, as well as generating accessors you request. Generated accessors will be getters, C setters will also be generated for you. You also get constants for each accessor (all caps) which return the key into the hash for that accessor. Single inheritence is also supported. =head1 METHODS =head2 PROVIDED BY HASH BASE =over 4 =item $it = $class->new(@VALUES) Create a new instance using key/value pairs. HashBase will not export C if there is already a C method in your packages inheritence chain. B you just have to declare it before loading L. package My::Package; # predeclare new() so that HashBase does not give us one. sub new; use Test2::Util::HashBase qw/foo bar baz/; # Now we define our own new method. sub new { ... } This makes it so that HashBase sees that you have your own C method. Alternatively you can define the method before loading HashBase instead of just declaring it, but that scatters your use statements. =back =head2 HOOKS =over 4 =item $self->init() This gives you the chance to set some default values to your fields. The only argument is C<$self> with its indexes already set from the constructor. =back =head1 ACCESSORS To generate accessors you list them when using the module: use Test2::Util::HashBase qw/foo/; This will generate the following subs in your namespace: =over 4 =item foo() Getter, used to get the value of the C field. =item set_foo() Setter, used to set the value of the C field. =item FOO() Constant, returs the field C's key into the class hashref. Subclasses will also get this function as a constant, not simply a method, that means it is copied into the subclass namespace. The main reason for using these constants is to help avoid spelling mistakes and similar typos. It will not help you if you forget to prefix the '+' though. =back =head1 SUBCLASSING You can subclass an existing HashBase class. use base 'Another::HashBase::Class'; use Test2::Util::HashBase qw/foo bar baz/; The base class is added to C<@ISA> for you, and all constants from base classes are added to subclasses automatically. =head1 SOURCE The source code repository for 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 2015 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 Waiting.pm100644001750001750 170612654206301 20136 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Eventpackage Test2::Event::Waiting; use strict; use warnings; use base 'Test2::Event'; sub global { 1 }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Waiting - Tell all procs/threads it is time to be done =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 DESCRIPTION This event has no data of its own. This event is sent out by the IPC system when the main process/thread is ready to end. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 254612654206301 20170 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Eventpackage Test2::Event::Subtest; use strict; use warnings; use base 'Test2::Event::Ok'; use Test2::Util::HashBase qw{subevents buffered}; sub init { my $self = shift; $self->SUPER::init(); $self->{+SUBEVENTS} ||= []; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Subtest - Event for subtest types =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 DESCRIPTION This class represents a subtest. This class is a subclass of L. =head1 ACCESSORS This class inherits from L. =over 4 =item $arrayref = $e->subevents Returns the arrayref containing all the events from the subtest =item $bool = $e->buffered True if the subtest is buffered, that is all subevents render at once. If this is false it means all subevents render as they are produced. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 Formatter000755001750001750 012654206301 16714 5ustar00exodistexodist000000000000Test2-0.000025/lib/Test2TAP.pm100644001750001750 2504012654206301 20057 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Formatterpackage Test2::Formatter::TAP; use strict; use warnings; use Test2::Util::HashBase qw{ no_numbers handles _encoding }; sub OUT_STD() { 0 } sub OUT_ERR() { 1 } use Carp qw/croak/; use base 'Test2::Formatter'; my %CONVERTERS = ( 'Test2::Event::Ok' => 'event_ok', 'Test2::Event::Skip' => 'event_skip', 'Test2::Event::Note' => 'event_note', 'Test2::Event::Diag' => 'event_diag', 'Test2::Event::Bail' => 'event_bail', 'Test2::Event::Exception' => 'event_exception', 'Test2::Event::Subtest' => 'event_subtest', 'Test2::Event::Plan' => 'event_plan', ); # Initial list of converters are safe for direct hash access cause we control them. my %SAFE_TO_ACCESS_HASH = %CONVERTERS; sub register_event { my $class = shift; my ($type, $convert) = @_; croak "Event type is a required argument" unless $type; croak "Event type '$type' already registered" if $CONVERTERS{$type}; croak "The second argument to register_event() must be a code reference or method name" unless $convert && (ref($convert) eq 'CODE' || $class->can($convert)); $CONVERTERS{$type} = $convert; } _autoflush(\*STDOUT); _autoflush(\*STDERR); sub init { my $self = shift; $self->{+HANDLES} ||= $self->_open_handles; if(my $enc = delete $self->{encoding}) { $self->encoding($enc); } } sub encoding { my $self = shift; if (@_) { my ($enc) = @_; my $handles = $self->{+HANDLES}; # https://rt.perl.org/Public/Bug/Display.html?id=31923 # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in # order to avoid the thread segfault. if ($enc =~ m/^utf-?8$/i) { binmode($_, ":utf8") for @$handles; } else { binmode($_, ":encoding($enc)") for @$handles; } $self->{+_ENCODING} = $enc; } return $self->{+_ENCODING}; } if ($^C) { no warnings 'redefine'; *write = sub {}; } sub write { my ($self, $e, $num) = @_; my $type = ref($e); my $converter = $CONVERTERS{$type} or return; my @tap = $self->$converter($e, $self->{+NO_NUMBERS} ? undef : $num) or return; my $handles = $self->{+HANDLES}; my $nesting = ($SAFE_TO_ACCESS_HASH{$type} ? $e->{nested} : $e->nested) || 0; my $indent = ' ' x $nesting; # Local is expensive! Only do it if we really need to. local($\, $,) = (undef, '') if $\ || $,; for my $set (@tap) { no warnings 'uninitialized'; my ($hid, $msg) = @$set; next unless $msg; my $io = $handles->[$hid] or next; $msg =~ s/^/$indent/mg if $nesting; print $io $msg; } } sub _open_handles { my $self = shift; open( my $out, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; open( my $err, ">&STDERR" ) or die "Can't dup STDERR: $!"; _autoflush($out); _autoflush($err); return [$out, $err]; } sub _autoflush { my($fh) = pop; my $old_fh = select $fh; $| = 1; select $old_fh; } sub event_tap { my $self = shift; my ($e, $num) = @_; my $converter = $CONVERTERS{ref($e)} or return; $num = undef if $self->{+NO_NUMBERS}; return $self->$converter($e, $num); } sub event_ok { my $self = shift; my ($e, $num) = @_; # We use direct hash access for performance. OK events are so common we # need this to be fast. my ($name, $todo) = @{$e}{qw/name todo/}; my $in_todo = defined($todo); my $out = ""; $out .= "not " unless $e->{pass}; $out .= "ok"; $out .= " $num" if defined($num); $out .= " - $name" if defined $name; $out .= " # TODO" if $in_todo; $out .= " $todo" if defined($todo) && length($todo); # The primary line of TAP, if the test passed this is all we need. return([OUT_STD, "$out\n"]); } sub event_skip { my $self = shift; my ($e, $num) = @_; my $name = $e->name; my $reason = $e->reason; my $todo = $e->todo; my $out = ""; $out .= "not " unless $e->{pass}; $out .= "ok"; $out .= " $num" if defined $num; $out .= " - $name" if $name; if (defined($todo)) { $out .= " # TODO & SKIP" } else { $out .= " # skip"; } $out .= " $reason" if defined($reason) && length($reason); return([OUT_STD, "$out\n"]); } sub event_note { my $self = shift; my ($e, $num) = @_; chomp(my $msg = $e->message); $msg =~ s/^/# /; $msg =~ s/\n/\n# /g; return [OUT_STD, "$msg\n"]; } sub event_diag { my $self = shift; my ($e, $num) = @_; chomp(my $msg = $e->message); $msg =~ s/^/# /; $msg =~ s/\n/\n# /g; return [OUT_ERR, "$msg\n"]; } sub event_bail { my $self = shift; my ($e, $num) = @_; return if $e->nested; return [ OUT_STD, "Bail out! " . $e->reason . "\n", ]; } sub event_exception { my $self = shift; my ($e, $num) = @_; return [ OUT_ERR, $e->error ]; } sub event_subtest { my $self = shift; my ($e, $num) = @_; # A 'subtest' is a subclass of 'ok'. Let the code that renders 'ok' render # this event. my ($ok, @diag) = $self->event_ok($e, $num); # If the subtest is not buffered then the sub-events have already been # rendered, we can go ahead and return. return ($ok, @diag) unless $e->buffered; # In a verbose harness we indent the diagnostics from the 'Ok' event since # they will appear inside the subtest braces. This helps readability. In a # non-verbose harness we do nto do this because it is less readable. if ($ENV{HARNESS_IS_VERBOSE}) { # index 0 is the filehandle, index 1 is the message we want to indent. $_->[1] =~ s/^(.*\S)$/ $1/mg for @diag; } # Add the trailing ' {' to the 'ok' line of TAP output. $ok->[1] =~ s/\n/ {\n/; # Render the sub-events, we use our own counter for these. my $count = 0; my @subs = map { # Bump the count for any event that should bump it. $count++ if $_->increments_count; # This indents all output lines generated for the sub-events. # index 0 is the filehandle, index 1 is the message we want to indent. map { $_->[1] =~ s/^(.*\S)$/ $1/mg; $_ } $self->event_tap($_, $count); } @{$e->subevents}; return ( $ok, # opening ok - name { @diag, # diagnostics if the subtest failed @subs, # All the inner-event lines [OUT_STD(), "}\n"], # } (closing brace) ); } sub event_plan { my $self = shift; my ($e, $num) = @_; my $directive = $e->directive; return if $directive && $directive eq 'NO PLAN'; my $reason = $e->reason; $reason =~ s/\n/\n# /g if $reason; my $plan = "1.." . $e->max; if ($directive) { $plan .= " # $directive"; $plan .= " $reason" if defined $reason; } return [OUT_STD, "$plan\n"]; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Formatter::TAP - Standard TAP formatter =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 DESCRIPTION This is what takes events and turns them into TAP. =head1 SYNOPSIS use Test2::Formatter::TAP; my $tap = Test2::Formatter::TAP->new(); # Switch to utf8 $tap->encoding('utf8'); $tap->write($event, $number); # Output an event =head1 METHODS =over 4 =item $bool = $tap->no_numbers =item $tap->set_no_numbers($bool) Use to turn numbers on and off. =item $arrayref = $tap->handles =item $tap->set_handles(\@handles); Can be used to get/set the filehandles. Indexes are identified by the C and C constants. =item $encoding = $tap->encoding =item $tap->encoding($encoding) Get or set the encoding. By default no encoding is set, the original settings of STDOUT and STDERR are used. This directly modifies the stored filehandles, it does not create new ones. =item $tap->write($e, $num) Write an event to the console. =item Test2::Formatter::TAP->register_event($pkg, sub { ... }); In general custom events are not supported. There are however occasions where you might want to write a custom event type that results in TAP output. In order to do this you use the C class method. package My::Event; use Test2::Formatter::TAP; use base 'Test2::Event'; use Test2::Util::HashBase accessors => [qw/pass name diag note/]; Test2::Formatter::TAP->register_event( __PACKAGE__, sub { my $self = shift; my ($e, $num) = @_; return ( [Test2::Formatter::TAP::OUT_STD, "ok $num - " . $e->name . "\n"], [Test2::Formatter::TAP::OUT_ERR, "# " . $e->name . " " . $e->diag . "\n"], [Test2::Formatter::TAP::OUT_STD, "# " . $e->name . " " . $e->note . "\n"], ); } ); 1; =back =head2 EVENT METHODS All these methods require the event itself. Optinally they can all except a test number. All methods return a list of array-refs. Each array-ref will have 2 items, the first is an integer identifying an output handle, the second is a string that should be written to the handle. =over 4 =item @out = $TAP->event_ok($e) =item @out = $TAP->event_ok($e, $num) Process an L event. =item @out = $TAP->event_plan($e) =item @out = $TAP->event_plan($e, $num) Process an L event. =item @out = $TAP->event_note($e) =item @out = $TAP->event_note($e, $num) Process an L event. =item @out = $TAP->event_diag($e) =item @out = $TAP->event_diag($e, $num) Process an L event. =item @out = $TAP->event_bail($e) =item @out = $TAP->event_bail($e, $num) Process an L event. =item @out = $TAP->event_exception($e) =item @out = $TAP->event_exception($e, $num) Process an L event. =item @out = $TAP->event_skip($e) =item @out = $TAP->event_skip($e, $num) Process an L event. =item @out = $TAP->event_subtest($e) =item @out = $TAP->event_subtest($e, $num) Process an L event. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =item Kent Fredric Ekentnl@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 acceptance000755001750001750 012654206301 15533 5ustar00exodistexodist000000000000Test2-0.000025/ttry_it_skip.t100644001750001750 31712654206301 20401 0ustar00exodistexodist000000000000Test2-0.000025/t/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 104212654206301 20410 0ustar00exodistexodist000000000000Test2-0.000025/t/acceptanceuse strict; use warnings; use Test2::Util qw/CAN_FORK/; use Test2::IPC; use Test2::API qw/context/; sub plan { my $ctx = context(); $ctx->plan(@_); $ctx->release; } sub ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } plan(0, skip_all => 'System cannot fork') unless CAN_FORK(); plan(6); for (1 .. 3) { my $pid = fork; die "Failed to fork" unless defined $pid; next if $pid; ok(1, "test 1 in pid $$"); ok(1, "test 2 in pid $$"); last; } 1; try_it_plan.t100644001750001750 45212654206301 20365 0ustar00exodistexodist000000000000Test2-0.000025/t/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; try_it_todo.t100644001750001750 167412654206301 20427 0ustar00exodistexodist000000000000Test2-0.000025/t/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"); diag "should be a diag"; done_testing; Interceptor.t100644001750001750 53112654206301 20435 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/Hubuse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::Hub::Interceptor; my $one = Test2::Hub::Interceptor->new(); ok($one->isa('Test2::Hub'), "inheritence");; my $e = exception { $one->terminate(55) }; ok($e->isa('Test2::Hub::Interceptor::Terminator'), "exception type"); is($$e, 55, "Scalar reference value"); done_testing; Exception.t100644001750001750 44412654206301 20443 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/Eventuse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::Event::Exception; my $exception = Test2::Event::Exception->new( trace => 'fake', error => "evil at lake_of_fire.t line 6\n", ); ok($exception->causes_fail, "Exception events always cause failure"); done_testing; Interceptor.pm100644001750001750 233212654206301 20463 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Hubpackage Test2::Hub::Interceptor; use strict; use warnings; use Test2::Hub::Interceptor::Terminator(); use base 'Test2::Hub'; use Test2::Util::HashBase; sub inherit { my $self = shift; my ($from, %params) = @_; if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { my $ipc = $from->{+IPC}; $self->{+IPC} = $ipc; $ipc->add_hub($self->{+HID}); } } sub terminate { my $self = shift; my ($code) = @_; die bless(\$code, 'Test2::Hub::Interceptor::Terminator'); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Hub::Interceptor - Hub used by interceptor to grab results. =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =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 2015 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 237412654206301 20474 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Eventpackage Test2::Event::Exception; use strict; use warnings; use base 'Test2::Event'; use Test2::Util::HashBase qw{error}; sub causes_fail { 1 } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Exception - Exception event =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =head1 DESCRIPTION An exception event will display to STDERR, and will prevent the overall test file from passing. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Exception; my $ctx = context(); my $event = $ctx->send_event('Exception', error => 'Stuff is broken'); =head1 METHODS Inherits from L. Also defines: =over 4 =item $reason = $e->error The reason for the exception. =back =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 Driver000755001750001750 012654206301 16763 5ustar00exodistexodist000000000000Test2-0.000025/t/modules/IPCFiles.t100644001750001750 2064212654206301 20376 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/IPC/DriverBEGIN { require "t/tools.pl" }; use Test2::Util qw/get_tid USE_THREADS try/; use File::Temp qw/tempfile/; sub capture(&) { my $code = shift; my ($err, $out) = ("", ""); my ($ok, $e); { local *STDOUT; local *STDERR; ($ok, $e) = try { open(STDOUT, '>', \$out) or die "Failed to open a temporary STDOUT: $!"; open(STDERR, '>', \$err) or die "Failed to open a temporary STDERR: $!"; $code->(); }; } die $e unless $ok; return { STDOUT => $out, STDERR => $err, }; } require Test2::IPC::Driver::Files; ok(my $ipc = Test2::IPC::Driver::Files->new, "Created an IPC instance"); ok($ipc->isa('Test2::IPC::Driver::Files'), "Correct type"); ok($ipc->isa('Test2::IPC::Driver'), "inheritence"); ok(-d $ipc->tempdir, "created temp dir"); is($ipc->pid, $$, "stored pid"); is($ipc->tid, get_tid(), "stored the tid"); my $hid = '12345'; $ipc->add_hub($hid); ok(-f $ipc->tempdir . '/HUB-' . $hid, "wrote hub file"); if(ok(open(my $fh, '<', $ipc->tempdir . '/HUB-' . $hid), "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')); opendir(my $dh, $ipc->tempdir) || die "Could not open tempdir: !?"; my @files = grep { $_ !~ m/^\.+$/ && $_ ne "HUB-$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/^\.+$/ && $_ ne "HUB-$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('GLOBAL', bless({global => 1}, 'Foo')); 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"); } { local *Test2::IPC::Driver::Files::abort = sub { my $self = shift; local $self->{no_fatal} = 1; $self->Test2::IPC::Driver::abort(@_); die 255; }; my $tmpdir; my @lines; my $file = __FILE__; my $out = 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; }; is($out->{STDOUT}, "not ok - IPC Fatal Error\nnot ok - IPC Fatal Error\n", "printed "); like($out->{STDERR}, qr/IPC Temp Dir: \Q$tmpdir\E/m, "Got temp dir path"); like($out->{STDERR}, qr/^# Not removing temp dir: \Q$tmpdir\E$/m, "Notice about not closing tempdir"); like($out->{STDERR}, qr/^IPC Fatal Error: File for hub '12345' already exists/m, "Got message for duplicate hub"); like($out->{STDERR}, qr/^IPC Fatal Error: File for hub '12345' does not exist/m, "Cannot remove hub twice"); $out = capture { my $ipc = Test2::IPC::Driver::Files->new(); $ipc->add_hub($hid); my $trace = Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']); my $e = eval { $ipc->send($hid, bless({glob => \*ok, trace => $trace}, 'Foo')); 1 }; print STDERR $@ unless $e || $@ =~ m/^255/; $ipc->drop_hub($hid); }; like($out->{STDERR}, qr/IPC Fatal Error:/, "Got fatal error"); like($out->{STDERR}, qr/There was an error writing an event/, "Explanation"); like($out->{STDERR}, qr/Destination: 12345/, "Got dest"); like($out->{STDERR}, qr/Origin PID:\s+$$/, "Got pid"); like($out->{STDERR}, qr/Error: Can't store GLOB items/, "Got cause"); $out = capture { my $ipc = Test2::IPC::Driver::Files->new(); local $@; eval { $ipc->send($hid, bless({ foo => 1 }, 'Foo')) }; print STDERR $@ unless $@ =~ m/^255/; $ipc = undef; }; is($out->{STDERR}, "IPC Fatal Error: hub '12345' is not available! Failed to send event!\n", "Cannot send to missing hub"); $out = capture { my $ipc = Test2::IPC::Driver::Files->new(); $ipc->add_hub($hid); $ipc->send($hid, bless({ foo => 1 }, 'Foo')); local $@; eval { $ipc->drop_hub($hid) }; print STDERR $@ unless $@ =~ m/^255/; }; like($out->{STDERR}, qr/IPC Fatal Error: Not all files from hub '12345' have been collected/, "Leftover files"); like($out->{STDERR}, qr/IPC Fatal Error: Leftover files in the directory \(.*\.ready\)/, "What file"); $out = 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 = 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 = 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 = 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 = 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('GLOBAL', bless({global => 1}, 'Foo')); $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; } done_testing; Driver000755001750001750 012654206301 16617 5ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/IPCFiles.pm100644001750001750 2057712654206301 20412 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/IPC/Driverpackage Test2::IPC::Driver::Files; use strict; use warnings; use base 'Test2::IPC::Driver'; use Test2::Util::HashBase qw{tempdir event_id tid pid globals}; use Scalar::Util qw/blessed/; use File::Temp(); use Storable(); use File::Spec(); use Test2::Util qw/try get_tid pkg_to_file/; use Test2::API qw/test2_ipc_set_pending/; sub use_shm { 1 } sub shm_size { 64 } sub is_viable { 1 } sub init { my $self = shift; my $tmpdir = File::Temp::tempdir('test2-XXXXXX', CLEANUP => 0, TMPDIR => 1); $self->abort_trace("Could not get a temp dir") unless $tmpdir; $self->{+TEMPDIR} = File::Spec->canonpath($tmpdir); print STDERR "\nIPC Temp Dir: $tmpdir\n\n" if $ENV{T2_KEEP_TEMPDIR}; $self->{+EVENT_ID} = 1; $self->{+TID} = get_tid(); $self->{+PID} = $$; $self->{+GLOBALS} = {}; return $self; } sub hub_file { my $self = shift; my ($hid) = @_; my $tdir = $self->{+TEMPDIR}; return File::Spec->canonpath("$tdir/HUB-$hid"); } sub event_file { my $self = shift; my ($hid, $e) = @_; my $tempdir = $self->{+TEMPDIR}; my $type = blessed($e) or $self->abort("'$e' is not a blessed object!"); $self->abort("'$e' is not an event object!") unless $type->isa('Test2::Event'); my @type = split '::', $type; my $name = join('-', $hid, $$, get_tid(), $self->{+EVENT_ID}++, @type); return File::Spec->canonpath("$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}) { rename($hfile, File::Spec->canonpath("$hfile.complete")) or $self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete'"); } else { unlink($hfile) or $self->abort_trace("Could not remove file for hub '$hid'"); } opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!"); for my $file (readdir($dh)) { next if $file =~ m{\.complete$}; next unless $file =~ m{^$hid}; $self->abort_trace("Not all files from hub '$hid' have been collected!"); } closedir($dh); } sub send { my $self = shift; my ($hid, $e) = @_; my $tempdir = $self->{+TEMPDIR}; my $global = $hid eq 'GLOBAL'; my $hfile = $self->hub_file($hid); $self->abort("hub '$hid' is not available! Failed to send event!\n") unless $global || -f $hfile; my $file = $self->event_file($hid, $e); my $ready = File::Spec->canonpath("$file.ready"); if ($global) { my $name = $ready; $name =~ s{^.*(GLOBAL)}{GLOBAL}; $self->globals->{$name}++; } my ($ok, $err) = try { Storable::store($e, $file); rename($file, $ready) or $self->abort("Could not rename file '$file' -> '$ready'"); test2_ipc_set_pending($file); }; if (!$ok) { my $src_file = __FILE__; $err =~ s{ at \Q$src_file\E.*$}{}; chomp($err); my $tid = get_tid(); my $trace = $e->trace->debug; my $type = blessed($e); $self->abort(<<" EOT"); ******************************************************************************* There was an error writing an event: Destination: $hid Origin PID: $$ Origin TID: $tid Event Type: $type Event Trace: $trace File Name: $file Ready Name: $ready Error: $err ******************************************************************************* EOT } return 1; } sub cull { my $self = shift; my ($hid) = @_; my $tempdir = $self->{+TEMPDIR}; opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!"); my @out; for my $file (sort readdir($dh)) { next if substr($file, 0, 1) eq '.'; next unless substr($file, -6, 6) eq '.ready'; my $global = substr($file, 0, 6) eq 'GLOBAL'; my $have_hid = !$global && substr($file, 0, length($hid)) eq $hid; next unless $have_hid || $global; next if $global && $self->{+GLOBALS}->{$file}++; # Untaint the path. my $full = File::Spec->canonpath("$tempdir/$file"); ($full) = ($full =~ m/^(.*)$/gs); my $obj = $self->read_event_file($full); # Do not remove global events unless ($global) { my $complete = File::Spec->canonpath("$full.complete"); if ($ENV{T2_KEEP_TEMPDIR}) { rename($full, $complete) or $self->abort("Could not rename IPC file '$full', '$complete'"); } else { unlink($full) or $self->abort("Could not unlink IPC file: $file"); } } push @out => $obj; } closedir($dh); return @out; } sub read_event_file { my $self = shift; my ($file) = @_; my $obj = Storable::retrieve($file); $self->abort("Got an unblessed object: '$obj'") unless blessed($obj); unless ($obj->isa('Test2::Event')) { my $pkg = blessed($obj); my $mod_file = pkg_to_file($pkg); my ($ok, $err) = try { require $mod_file }; $self->abort("Event has unknown type ($pkg), tried to load '$mod_file' but failed: $err") unless $ok; $self->abort("'$obj' is not a 'Test2::Event' object") unless $obj->isa('Test2::Event'); } return $obj; } sub waiting { my $self = shift; require Test2::Event::Waiting; $self->send( GLOBAL => Test2::Event::Waiting->new( trace => Test2::Util::Trace->new(frame => [caller()]), ) ); return; } sub DESTROY { my $self = shift; return unless defined $self->pid; return unless defined $self->tid; return unless $$ == $self->pid; return unless get_tid() == $self->tid; my $tempdir = $self->{+TEMPDIR}; opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)"); while(my $file = readdir($dh)) { next if $file =~ m/^\.+$/; next if $file =~ m/\.complete$/; my $full = File::Spec->canonpath("$tempdir/$file"); if ($file =~ m/^(GLOBAL|HUB-)/) { $full =~ m/^(.*)$/; $full = $1; # Untaint it next if $ENV{T2_KEEP_TEMPDIR}; unlink($full) or $self->abort("Could not unlink IPC file: $full"); next; } $self->abort("Leftover files in the directory ($full)!\n"); } closedir($dh); if ($ENV{T2_KEEP_TEMPDIR}) { print STDERR "# Not removing temp dir: $tempdir\n"; return; } rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)"; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::IPC::Driver::Files - Temp dir + Files concurrency model. =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =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 particularily fast, but it works everywhere. =head1 SYNOPSIS use Test2::IPC::Driver::Files; # IPC is now enabled =head1 SEE ALSO See L for methods. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 try_it_no_plan.t100644001750001750 46512654206301 21065 0ustar00exodistexodist000000000000Test2-0.000025/t/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; try_it_threads.t100644001750001750 110312654206301 21077 0ustar00exodistexodist000000000000Test2-0.000025/t/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; ExternalMeta.t100644001750001750 350412654206301 20752 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/Utiluse strict; use warnings; BEGIN { require "t/tools.pl" }; { 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; ExternalMeta.pm100644001750001750 735312654206301 20765 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Utilpackage Test2::Util::ExternalMeta; use strict; use warnings; use Carp qw/croak/; sub META_KEY() { '_meta' } our @EXPORT = qw/meta set_meta get_meta delete_meta/; use base '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 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =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 SYNOPSYS 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 specfi 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 RESTICTIONS Meta keys must be defined, and must be true when used as a boolean. Keys may not be references. You are free to stringify a reference C<"$ref"> for use as a key, but this package will not stringify it for you. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2015 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 try_it_done_testing.t100644001750001750 60012654206301 22110 0ustar00exodistexodist000000000000Test2-0.000025/t/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; regression000755001750001750 012654206301 15625 5ustar00exodistexodist000000000000Test2-0.000025/tipc_files_abort_exit.t100644001750001750 237212654206301 22333 0ustar00exodistexodist000000000000Test2-0.000025/t/regressionuse strict; use warnings; use Test2::IPC; BEGIN { require "t/tools.pl" }; use Test2::API qw/context test2_stack/; use Test2::Util qw/CAN_FORK/; BEGIN { skip_all "System cannot fork" unless CAN_FORK; } plan(3); pipe(my ($read, $write)); test2_stack()->top; my $hub = test2_stack()->new_hub(); my $pid = fork(); die "Failed to fork" unless defined $pid; if ($pid) { close($read); test2_stack()->pop($hub); $hub = undef; print $write "Go\n"; close($write); waitpid($pid, 0); my $err = $? >> 8; is($err, 255, "Exit code was not masked"); ok($err != 100, "Did not hit the safety exit"); } else { close($write); my $ignore = <$read>; close($read); close(STDERR); close(STDOUT); open(STDERR, '>', my $x); my $ctx = context(hub => $hub, level => -1); my $clone = $ctx->snapshot; $ctx->release; $clone->ok(0, "Should not see this"); print STDERR "\n\nSomething went wrong!!!!\n\n"; exit 100; # Safety exit }; # The rest of this is to make sure nothing that happens when reading the event # messes with $?. pipe($read, $write); $pid = fork; die "Failed to fork" unless defined $pid; unless($pid) { my $ignore = <$read>; ok(1, "Test in forked process"); } print $write "Go\n"; nested_context_exception.t100644001750001750 400612654206301 22675 0ustar00exodistexodist000000000000Test2-0.000025/t/behavioruse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::API qw/context/; sub outer { my $code = shift; my $ctx = context(); $ctx->note("outer"); my $out = eval { $code->() }; $ctx->release; return $out; } sub dies { my $ctx = context(); $ctx->note("dies"); die "Foo"; } sub bad_store { my $ctx = context(); $ctx->note("bad store"); return $ctx; # Emulate storing it somewhere } sub bad_simple { my $ctx = context(); $ctx->note("bad simple"); return; } my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; eval { dies() }; } ok(!@warnings, "no warnings") || diag @warnings; @warnings = (); my $keep = bad_store(); eval { my $x = 1 }; # Ensure an eval changing $@ does not meddle. { local $SIG{__WARN__} = sub { push @warnings => @_ }; ok(1, "random event"); } ok(@warnings, "got warnings"); like( $warnings[0], qr/context\(\) was called to retrieve an existing context/, "got expected warning" ); $keep = undef; { @warnings = (); local $SIG{__WARN__} = sub { push @warnings => @_ }; bad_simple(); } ok(@warnings, "got warnings"); like( $warnings[0], qr/A context appears to have been destroyed without first calling release/, "got expected warning" ); @warnings = (); outer(\&dies); { local $SIG{__WARN__} = sub { push @warnings => @_ }; ok(1, "random event"); } ok(!@warnings, "no warnings") || diag @warnings; @warnings = (); { local $SIG{__WARN__} = sub { push @warnings => @_ }; outer(\&bad_store); } ok(@warnings, "got warnings"); like( $warnings[0], qr/A context appears to have been destroyed without first calling release/, "got expected warning" ); { @warnings = (); local $SIG{__WARN__} = sub { push @warnings => @_ }; outer(\&bad_simple); } ok(@warnings, "got warnings") || diag @warnings; like( $warnings[0], qr/A context appears to have been destroyed without first calling release/, "got expected warning" ); done_testing; Interceptor000755001750001750 012654206301 20131 5ustar00exodistexodist000000000000Test2-0.000025/t/modules/HubTerminator.t100644001750001750 25712654206301 22566 0ustar00exodistexodist000000000000Test2-0.000025/t/modules/Hub/Interceptoruse strict; use warnings; BEGIN { require "t/tools.pl" }; use Test2::Hub::Interceptor::Terminator; ok($INC{'Test2/Hub/Interceptor/Terminator.pm'}, "loaded"); done_testing; Interceptor000755001750001750 012654206301 17765 5ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/HubTerminator.pm100644001750001750 145112654206301 22610 0ustar00exodistexodist000000000000Test2-0.000025/lib/Test2/Hub/Interceptorpackage Test2::Hub::Interceptor::Terminator; use strict; use warnings; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Hub::Interceptor::Terminator - Exception class used by Test2::Hub::Interceptor =head1 EXPERIMENTAL RELEASE This is an experimental release. Using this right now is not recommended. =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 2015 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