From 756fec59fb18706a03f73495c4a2f9b262d57ffe Mon Sep 17 00:00:00 2001 From: TizenOpenSource Date: Thu, 8 Feb 2024 16:54:00 +0900 Subject: [PATCH] Imported Upstream version 0.48 --- CONTRIBUTING.mkdn | 87 ++++ Changes | 403 ++++++++++++++++ LICENSE | 207 +++++++++ MANIFEST | 54 +++ META.json | 115 +++++ META.yml | 55 +++ Makefile.PL | 72 +++ README | 375 +++++++++++++++ Todo | 8 + cpanfile | 50 ++ dist.ini | 29 ++ examples/rt-58208.pl | 11 + examples/tee.pl | 18 + lib/Capture/Tiny.pm | 901 ++++++++++++++++++++++++++++++++++++ perlcritic.rc | 26 ++ t/00-report-prereqs.dd | 60 +++ t/00-report-prereqs.t | 193 ++++++++ t/01-Capture-Tiny.t | 37 ++ t/02-capture.t | 29 ++ t/03-tee.t | 36 ++ t/06-stdout-closed.t | 49 ++ t/07-stderr-closed.t | 48 ++ t/08-stdin-closed.t | 65 +++ t/09-preserve-exit-code.t | 30 ++ t/10-stdout-string.t | 53 +++ t/11-stderr-string.t | 52 +++ t/12-stdin-string.t | 59 +++ t/13-stdout-tied.t | 56 +++ t/14-stderr-tied.t | 56 +++ t/15-stdin-tied.t | 58 +++ t/16-catch-errors.t | 47 ++ t/17-pass-results.t | 87 ++++ t/18-custom-capture.t | 169 +++++++ t/19-relayering.t | 83 ++++ t/20-stdout-badtie.t | 54 +++ t/21-stderr-badtie.t | 54 +++ t/22-stdin-badtie.t | 54 +++ t/23-all-tied.t | 64 +++ t/24-all-badtied.t | 64 +++ t/25-cap-fork.t | 50 ++ t/lib/Cases.pm | 286 ++++++++++++ t/lib/TieEvil.pm | 35 ++ t/lib/TieLC.pm | 44 ++ t/lib/Utils.pm | 60 +++ xt/author/00-compile.t | 63 +++ xt/author/critic.t | 7 + xt/author/minimum-version.t | 6 + xt/author/pod-coverage.t | 7 + xt/author/pod-spell.t | 37 ++ xt/author/pod-syntax.t | 7 + xt/author/portability.t | 10 + xt/author/test-version.t | 23 + xt/release/distmeta.t | 6 + 53 files changed, 4609 insertions(+) create mode 100644 CONTRIBUTING.mkdn create mode 100644 Changes create mode 100644 LICENSE create mode 100644 MANIFEST create mode 100644 META.json create mode 100644 META.yml create mode 100644 Makefile.PL create mode 100644 README create mode 100644 Todo create mode 100644 cpanfile create mode 100644 dist.ini create mode 100644 examples/rt-58208.pl create mode 100644 examples/tee.pl create mode 100644 lib/Capture/Tiny.pm create mode 100644 perlcritic.rc create mode 100644 t/00-report-prereqs.dd create mode 100644 t/00-report-prereqs.t create mode 100644 t/01-Capture-Tiny.t create mode 100644 t/02-capture.t create mode 100644 t/03-tee.t create mode 100644 t/06-stdout-closed.t create mode 100644 t/07-stderr-closed.t create mode 100644 t/08-stdin-closed.t create mode 100644 t/09-preserve-exit-code.t create mode 100644 t/10-stdout-string.t create mode 100644 t/11-stderr-string.t create mode 100644 t/12-stdin-string.t create mode 100644 t/13-stdout-tied.t create mode 100644 t/14-stderr-tied.t create mode 100644 t/15-stdin-tied.t create mode 100644 t/16-catch-errors.t create mode 100644 t/17-pass-results.t create mode 100644 t/18-custom-capture.t create mode 100644 t/19-relayering.t create mode 100644 t/20-stdout-badtie.t create mode 100644 t/21-stderr-badtie.t create mode 100644 t/22-stdin-badtie.t create mode 100644 t/23-all-tied.t create mode 100644 t/24-all-badtied.t create mode 100644 t/25-cap-fork.t create mode 100644 t/lib/Cases.pm create mode 100644 t/lib/TieEvil.pm create mode 100644 t/lib/TieLC.pm create mode 100644 t/lib/Utils.pm create mode 100644 xt/author/00-compile.t create mode 100644 xt/author/critic.t create mode 100644 xt/author/minimum-version.t create mode 100644 xt/author/pod-coverage.t create mode 100644 xt/author/pod-spell.t create mode 100644 xt/author/pod-syntax.t create mode 100644 xt/author/portability.t create mode 100644 xt/author/test-version.t create mode 100644 xt/release/distmeta.t diff --git a/CONTRIBUTING.mkdn b/CONTRIBUTING.mkdn new file mode 100644 index 0000000..761c9db --- /dev/null +++ b/CONTRIBUTING.mkdn @@ -0,0 +1,87 @@ +## HOW TO CONTRIBUTE + +Thank you for considering contributing to this distribution. This file +contains instructions that will help you work with the source code. + +The distribution is managed with Dist::Zilla. This means than many of the +usual files you might expect are not in the repository, but are generated at +release time, as is much of the documentation. Some generated files are +kept in the repository as a convenience (e.g. Makefile.PL or cpanfile). + +Generally, **you do not need Dist::Zilla to contribute patches**. You do need +Dist::Zilla to create a tarball. See below for guidance. + +### Getting dependencies + +If you have App::cpanminus 1.6 or later installed, you can use `cpanm` to +satisfy dependencies like this: + + $ cpanm --installdeps . + +Otherwise, look for either a `Makefile.PL` or `cpanfile` file for +a list of dependencies to satisfy. + +### Running tests + +You can run tests directly using the `prove` tool: + + $ prove -l + $ prove -lv t/some_test_file.t + +For most of my distributions, `prove` is entirely sufficient for you to test any +patches you have. I use `prove` for 99% of my testing during development. + +### Code style and tidying + +Please try to match any existing coding style. If there is a `.perltidyrc` +file, please install Perl::Tidy and use perltidy before submitting patches. + +If there is a `tidyall.ini` file, you can also install Code::TidyAll and run +`tidyall` on a file or `tidyall -a` to tidy all files. + +### Patching documentation + +Much of the documentation Pod is generated at release time. Some is +generated boilerplate; other documentation is built from pseudo-POD +directives in the source like C<=method> or C<=func>. + +If you would like to submit a documentation edit, please limit yourself to +the documentation you see. + +If you see typos or documentation issues in the generated docs, please +email or open a bug ticket instead of patching. + +### Installing and using Dist::Zilla + +Dist::Zilla is a very powerful authoring tool, optimized for maintaining a +large number of distributions with a high degree of automation, but it has a +large dependency chain, a bit of a learning curve and requires a number of +author-specific plugins. + +To install it from CPAN, I recommend one of the following approaches for +the quickest installation: + + # using CPAN.pm, but bypassing non-functional pod tests + $ cpan TAP::Harness::Restricted + $ PERL_MM_USE_DEFAULT=1 HARNESS_CLASS=TAP::Harness::Restricted cpan Dist::Zilla + + # using cpanm, bypassing *all* tests + $ cpanm -n Dist::Zilla + +In either case, it's probably going to take about 10 minutes. Go for a walk, +go get a cup of your favorite beverage, take a bathroom break, or whatever. +When you get back, Dist::Zilla should be ready for you. + +Then you need to install any plugins specific to this distribution: + + $ cpan `dzil authordeps` + $ dzil authordeps | cpanm + +Once installed, here are some dzil commands you might try: + + $ dzil build + $ dzil test + $ dzil xtest + +You can learn more about Dist::Zilla at http://dzil.org/ + diff --git a/Changes b/Changes new file mode 100644 index 0000000..ed37516 --- /dev/null +++ b/Changes @@ -0,0 +1,403 @@ +Revision history for Capture-Tiny + +0.48 2018-04-22 09:01:08+02:00 Europe/Oslo + + - No changes from 0.47-TRIAL + +0.47 2017-07-26 10:34:24-04:00 America/New_York (TRIAL RELEASE) + + [Fixed] + + - Appends PID to random file names for tee signalling to avoid + random name collision when used in multiple forked children. + +0.46 2017-02-25 14:19:22-05:00 America/New_York + + - No changes from 0.45-TRIAL + +0.45 2017-02-23 13:22:43-05:00 America/New_York (TRIAL RELEASE) + + [Internal] + + - Avoid variable shadowing to improve debuggability. + +0.44 2016-08-05 13:40:33-04:00 America/New_York + + [Docs] + + - Note that dropping privileges during a capture can lead to + temporary files not cleaned up. + +0.42 2016-05-31 12:40:10-04:00 America/New_York + + - No changes from 0.41 + +0.41 2016-05-23 11:58:15-04:00 America/New_York (TRIAL RELEASE) + + [Fixed] + + - Fixed some failing tests when STDIN is routed to /dev/null + +0.40 2016-05-23 11:42:35-04:00 America/New_York + + - No changes from 0.39 + +0.39 2016-05-02 10:21:48-04:00 America/New_York (TRIAL RELEASE) + + [Fixed] + + - Fix in 0.37 tickled a very obscure regular expressions bug in perl < + 5.18; should now be fixed. + +0.37 2016-05-02 07:08:31-04:00 America/New_York (TRIAL RELEASE) + + [Fixed] + + - Skip some tests if locale can't be determined. + +0.36 2016-02-28 21:36:57-05:00 America/New_York + + [Docs] + + - Fixed typos. + +0.34 2016-02-18 23:26:13-05:00 America/New_York + + [Fixed] + + - Removed spurious JSON::PP dependency added by a broken + Dist::Zilla plugin. + +0.32 2016-02-18 10:12:02-05:00 America/New_York + + [Docs] + + - Changed internal formatting of documentation + + [Changes] + + - No functional changes from 0.31 + +0.31 2016-02-14 07:33:50-07:00 America/Mazatlan (TRIAL RELEASE) + + [Fixed] + + - Application of layers to handles during and after capture now attempts + to more accurately duplicate the original layers, including potential + duplicate layers. Because of the unusual ways that layers are ordered + and applied, exact duplication is not guaranteeed, but this should be + better that what Capture::Tiny did before. + + - Avoids a hard crash on Windows with Perl < 5.20 if a fork occurs in a + capture block. Also documented the risks and lack of support for + forks in capture blocks. + +0.30 2015-05-15 20:43:54-04:00 America/New_York + + No changes from 0.29 + +0.29 2015-04-19 18:36:24+02:00 Europe/Berlin (TRIAL RELEASE) + + Fixed: + + - Fix double filehandle close error with tee on Windows + (which started warning during the perl 5.21.x series, + causing tests to fail) + +0.28 2015-02-11 06:39:51-05:00 America/New_York + + Tests: + + - Removes test that optionally uses Inline::C to avoid spurious + test failures. Also Inline::C had become a fairly heavy + (if optional) dependency. + + Docs: + + - Clarify that PERL_CAPTURE_TINY_TIMEOUT is an internal control, + not a timeout of the code reference being captured. + +0.27 2014-11-04 23:10:44-05:00 America/New_York + + Prereqs: + + - Make Inline::C recommended, not required + +0.26 2014-11-04 06:55:15-05:00 America/New_York + + Tests: + + - Actually check for Inline::C in tests, not just Inline + +0.25 2014-08-16 10:08:42-04:00 America/New_York + + Prereqs: + + - Amended recommended modules to list Inline::C rather than Inline + +0.24 2014-02-06 17:15:37-05:00 America/New_York + + Fixed: + + - Closed security hole in use of semaphore file in /tmp; + now opens the semaphore file using O_CREAT|O_EXCL + +0.23 2013-10-20 11:25:34 America/New_York + + Fixed: + + - minimum Perl prereq is back to 5.6 (but $diety help you if + you're still stuck on 5.6) + + Documented: + + - Added warning about using @_ in a capture block + +0.22 2013-03-27 15:50:29 America/New_York + + Documented: + + - Issue tracker is now github + +0.21 2012-11-14 19:04:49 America/New_York + + Changed: + + - Skips tee and leak tests for closed STDIN on Perl prior to + 5.12 when PERL_UNICODE=D. Documented lack of support as + a known issue. + + - Isolated tee subprocesses from effects of PERL_UNICODE as a + precaution (though this did not fix the above issue). + + - Improved layer detection for handles proxied due to being closed + or tied. + +0.20 2012-09-19 13:20:57 America/New_York + + Fixed: + + - Nested merged captures that include an external program call no longer + leak STDERR to the outer scope [rt.cpan.org #79376] + +0.19 2012-08-06 20:26:34 America/New_York + + Fixed: + + - Work around rt.perl.org #114404 by forcing PerlIO layers back on + original handles [rt.cpan.org #78819] + +0.18 2012-05-04 16:31:53 America/New_York + + Added: + + - When capture or tee are called in void context, Capture::Tiny + skips reading back from the capture handles if it can do so safely + +0.17_52 2012-03-09 11:45:19 EST5EDT + + Fixed: + + - Tied STDIN is always localized before redirections to avoid tees + hanging on MSWin32 + + - Copying and reopening STDIN is necessary to avoid tees hanging on MSWin32. + +0.17_51 2012-03-07 18:22:34 EST5EDT + + Fixed: + + - Avoids reopening STDIN while setting up a capture, which avoids + some problems with pathological tied filehandle implementations + such as in FCGI + + Tested: + + - Re-enabled tied STDIN testing for MSWin32 to see if changes above + avoid crashes seen historically + +0.17 2012-02-22 08:07:41 EST5EDT + + Fixed: + + - Added a workaround for failing t/08-stdin-closed.t under blead + perl / 5.15.8 [rt.perl.org #111070] + + Documented: + + - Clarified some limitations; added a link to CPAN Testers Matrix; + removed redundant BUGS section; standardized terminology + + Tested: + + - Added a test using Inline::C to print to stdout and stderr in response + to rt.cpan.org #71701 + +0.16 2012-02-12 21:04:24 EST5EDT + + Documented: + + - Noted problems and workaround for FCGI's pathological tied STDIN + [rt.cpan.org #74681; thank you Karl Gaissmaier for testing the + workaround] + +0.15 2011-12-23 11:10:47 EST5EDT + + Fixed: + + - Repeated captures from a custom filehandle would return undef instead + of the empty string (and would warn). This has been fixed. + [rt.cpan.org #73374 part two. Thank you to Philipp Herz for help + in reproducing this bug.] + + Other: + + - Commented out debugging code for slightly less runtime overhead + +0.14 2011-12-22 10:14:09 EST5EDT + + Added: + + - Capturing with custom filehandles will return only newly appended + output instead of everything already in the file. + [rt.cpan.org #73374] + +0.13 2011-12-02 13:39:00 EST5EDT + + Fixed: + + - Fixed t/18-custom-capture.t failures on Windows due to tempfile + removal problems in the testfile + +0.12 2011-12-01 16:58:05 EST5EDT + + Added: + + - New functions capture_stdout, capture_stderr, tee_stdout, tee_stderr + [rt.cpan.org #60515] + + - Capture functions also returns the return values from the executed + coderef [rt.cpan.org #61794, adapted from patch by Christian Walde] + + - Capture functions take optional custom filehandles for capturing + via named files instead of anonymous ones [inspired by Christian Walde] + + Fixed: + + - Tied filehandles based on Tie::StdHandle can now use the ":utf8" + layer; removed remaining TODO tests; adds Scalar::Util as a dependency + + Changed: + + - When Time::HiRes::usleep is available, tee operations will + sleep during the busy-loop waiting for tee processes to be ready + [rt.cpan.org #67858] + +0.11 2011-05-19 23:34:23 America/New_York + + Fixed: + + - Tests will not use Test::Differences version 0.60 or greater + +0.10 2011-02-07 07:01:44 EST5EDT + + Fixed: + + - Setting PERL_CAPTURE_TINY_TIMEOUT to 0 will disable timeouts + +0.09 2011-01-27 23:52:16 EST5EDT + + Added: + + - Added support for $ENV{PERL_CAPTURE_TINY_TIMEOUT} to control + the timeout period under 'tee'; tests set not to timeout to + avoid false FAIL reports on overloaded virtual machine smokers + + Fixed: + + - $@ set within a captured block is no longer lost when the capture + is completed; likewise, the initial value of $@ is not lost + during capture (when no subsequent error occurs) (RT #65139) + +0.08 Sun Jun 20 19:13:19 EDT 2010 + + Fixed: + + - Exceptions in captured coderef are caught, then handles are restored + before the exception is rethrown (RT #58208) + +0.07 Sun Jan 24 00:18:45 EST 2010 + + Fixed: + + - Changed test for $? preservation to be more portable + + - Dropped support for Perl 5.8.0 specifically due to excessive bugs. + Tests will bail out. (5.6.X is still supported) + +0.06 Thu May 7 06:54:53 EDT 2009 + + Fixed: + + - On Win32, subprocesses now close themselves on EOF instead of being + killed with a signal + +0.05_51 Tue Apr 21 07:00:38 EDT 2009 + + Added: + + - Support for wide characters on handles opened to utf8 + + - Support for STDOUT, STDERR or STDIN opened to in-memory + files (open to scalar reference) or tied, albeit with some limitations + + Testing: + + - Verify that $? is preserved during capture { system(@cmd) }; + +0.05 Tue Mar 3 06:56:05 EST 2009 + + Fixed: + + - On Win32, increased a delay waiting for buffers to flush to avoid losing + final output during tee() + +0.04 Wed Feb 25 09:25:27 EST 2009 + + Added: + + - Can capture/tee even if STDIN, STDOUT or STDERR are closed prior to + capture/tee block + + - Generally, added more error handling + + Fixed: + + - Will timeout instead of hang if subprocesses fail to start + +0.03 Fri Feb 20 13:03:08 EST 2009 + + Added: + + - capture_merged() and tee_merged() + + Fixed: + + - Tests skip if not Win32 and no fork() (rather than Build.PL and + Makefile.PL failing); this allows capture() on odd platforms, even if + fork doesn't work + +0.02 Tue Feb 17 17:24:35 EST 2009 + + Fixed: + + - Bug recovering output when STDOUT is empty (reported by Vincent Pit) + + - Removed Fatal.pm to avoid global action-at-a-distance + +0.01 Fri Feb 13 23:15:19 EST 2009 + + Added: + - 'capture' and 'tee' functions + +# vim: set ts=2 sts=2 sw=2 et tw=75: diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..ff0126d --- /dev/null +++ b/LICENSE @@ -0,0 +1,207 @@ +This software is Copyright (c) 2009 by David Golden. + +This is free software, licensed under: + + The Apache License, Version 2.0, January 2004 + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..bf5264a --- /dev/null +++ b/MANIFEST @@ -0,0 +1,54 @@ +# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.012. +CONTRIBUTING.mkdn +Changes +LICENSE +MANIFEST +META.json +META.yml +Makefile.PL +README +Todo +cpanfile +dist.ini +examples/rt-58208.pl +examples/tee.pl +lib/Capture/Tiny.pm +perlcritic.rc +t/00-report-prereqs.dd +t/00-report-prereqs.t +t/01-Capture-Tiny.t +t/02-capture.t +t/03-tee.t +t/06-stdout-closed.t +t/07-stderr-closed.t +t/08-stdin-closed.t +t/09-preserve-exit-code.t +t/10-stdout-string.t +t/11-stderr-string.t +t/12-stdin-string.t +t/13-stdout-tied.t +t/14-stderr-tied.t +t/15-stdin-tied.t +t/16-catch-errors.t +t/17-pass-results.t +t/18-custom-capture.t +t/19-relayering.t +t/20-stdout-badtie.t +t/21-stderr-badtie.t +t/22-stdin-badtie.t +t/23-all-tied.t +t/24-all-badtied.t +t/25-cap-fork.t +t/lib/Cases.pm +t/lib/TieEvil.pm +t/lib/TieLC.pm +t/lib/Utils.pm +xt/author/00-compile.t +xt/author/critic.t +xt/author/minimum-version.t +xt/author/pod-coverage.t +xt/author/pod-spell.t +xt/author/pod-syntax.t +xt/author/portability.t +xt/author/test-version.t +xt/release/distmeta.t diff --git a/META.json b/META.json new file mode 100644 index 0000000..257e4f9 --- /dev/null +++ b/META.json @@ -0,0 +1,115 @@ +{ + "abstract" : "Capture STDOUT and STDERR from Perl, XS or external programs", + "author" : [ + "David Golden " + ], + "dynamic_config" : 1, + "generated_by" : "Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010", + "license" : [ + "apache_2_0" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "Capture-Tiny", + "no_index" : { + "directory" : [ + "corpus", + "examples", + "t", + "xt" + ], + "package" : [ + "DB" + ] + }, + "prereqs" : { + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "6.17" + } + }, + "develop" : { + "requires" : { + "Dist::Zilla" : "5", + "Dist::Zilla::Plugin::OSPrereqs" : "0", + "Dist::Zilla::Plugin::Prereqs" : "0", + "Dist::Zilla::Plugin::ReleaseStatus::FromVersion" : "0", + "Dist::Zilla::Plugin::RemovePrereqs" : "0", + "Dist::Zilla::PluginBundle::DAGOLDEN" : "0.072", + "File::Spec" : "0", + "File::Temp" : "0", + "IO::Handle" : "0", + "IPC::Open3" : "0", + "Pod::Coverage::TrustPod" : "0", + "Pod::Wordlist" : "0", + "Software::License::Apache_2_0" : "0", + "Test::CPAN::Meta" : "0", + "Test::MinimumVersion" : "0", + "Test::More" : "0", + "Test::Perl::Critic" : "0", + "Test::Pod" : "1.41", + "Test::Pod::Coverage" : "1.08", + "Test::Portability::Files" : "0", + "Test::Spelling" : "0.12", + "Test::Version" : "1" + } + }, + "runtime" : { + "requires" : { + "Carp" : "0", + "Exporter" : "0", + "File::Spec" : "0", + "File::Temp" : "0", + "IO::Handle" : "0", + "Scalar::Util" : "0", + "perl" : "5.006", + "strict" : "0", + "warnings" : "0" + } + }, + "test" : { + "recommends" : { + "CPAN::Meta" : "2.120900" + }, + "requires" : { + "ExtUtils::MakeMaker" : "0", + "File::Spec" : "0", + "IO::File" : "0", + "Test::More" : "0.62", + "lib" : "0" + } + } + }, + "provides" : { + "Capture::Tiny" : { + "file" : "lib/Capture/Tiny.pm", + "version" : "0.48" + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "web" : "https://github.com/dagolden/Capture-Tiny/issues" + }, + "homepage" : "https://github.com/dagolden/Capture-Tiny", + "repository" : { + "type" : "git", + "url" : "https://github.com/dagolden/Capture-Tiny.git", + "web" : "https://github.com/dagolden/Capture-Tiny" + } + }, + "version" : "0.48", + "x_authority" : "cpan:DAGOLDEN", + "x_contributors" : [ + "Dagfinn Ilmari Manns\u00e5ker ", + "David E. Wheeler ", + "fecundf ", + "Graham Knop ", + "Peter Rabbitson " + ], + "x_generated_by_perl" : "v5.26.1", + "x_serialization_backend" : "Cpanel::JSON::XS version 3.0239" +} + diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..8007bf0 --- /dev/null +++ b/META.yml @@ -0,0 +1,55 @@ +--- +abstract: 'Capture STDOUT and STDERR from Perl, XS or external programs' +author: + - 'David Golden ' +build_requires: + ExtUtils::MakeMaker: '0' + File::Spec: '0' + IO::File: '0' + Test::More: '0.62' + lib: '0' +configure_requires: + ExtUtils::MakeMaker: '6.17' +dynamic_config: 1 +generated_by: 'Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010' +license: apache +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Capture-Tiny +no_index: + directory: + - corpus + - examples + - t + - xt + package: + - DB +provides: + Capture::Tiny: + file: lib/Capture/Tiny.pm + version: '0.48' +requires: + Carp: '0' + Exporter: '0' + File::Spec: '0' + File::Temp: '0' + IO::Handle: '0' + Scalar::Util: '0' + perl: '5.006' + strict: '0' + warnings: '0' +resources: + bugtracker: https://github.com/dagolden/Capture-Tiny/issues + homepage: https://github.com/dagolden/Capture-Tiny + repository: https://github.com/dagolden/Capture-Tiny.git +version: '0.48' +x_authority: cpan:DAGOLDEN +x_contributors: + - 'Dagfinn Ilmari Mannsåker ' + - 'David E. Wheeler ' + - 'fecundf ' + - 'Graham Knop ' + - 'Peter Rabbitson ' +x_generated_by_perl: v5.26.1 +x_serialization_backend: 'YAML::Tiny version 1.70' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..04669d3 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,72 @@ +# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.012. +use strict; +use warnings; + +use 5.006; + +use ExtUtils::MakeMaker 6.17; + +my %WriteMakefileArgs = ( + "ABSTRACT" => "Capture STDOUT and STDERR from Perl, XS or external programs", + "AUTHOR" => "David Golden ", + "CONFIGURE_REQUIRES" => { + "ExtUtils::MakeMaker" => "6.17" + }, + "DISTNAME" => "Capture-Tiny", + "LICENSE" => "apache", + "MIN_PERL_VERSION" => "5.006", + "NAME" => "Capture::Tiny", + "PREREQ_PM" => { + "Carp" => 0, + "Exporter" => 0, + "File::Spec" => 0, + "File::Temp" => 0, + "IO::Handle" => 0, + "Scalar::Util" => 0, + "strict" => 0, + "warnings" => 0 + }, + "TEST_REQUIRES" => { + "ExtUtils::MakeMaker" => 0, + "File::Spec" => 0, + "IO::File" => 0, + "Test::More" => "0.62", + "lib" => 0 + }, + "VERSION" => "0.48", + "test" => { + "TESTS" => "t/*.t" + } +); + + +my %FallbackPrereqs = ( + "Carp" => 0, + "Exporter" => 0, + "ExtUtils::MakeMaker" => 0, + "File::Spec" => 0, + "File::Temp" => 0, + "IO::File" => 0, + "IO::Handle" => 0, + "Scalar::Util" => 0, + "Test::More" => "0.62", + "lib" => 0, + "strict" => 0, + "warnings" => 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) }; + +if ( $^O eq 'MSWin32' ) { + $WriteMakefileArgs{PREREQ_PM}{'Win32API::File'} = $FallbackPrereqs{'Win32API::File'} = '0'; +} + +WriteMakefile(%WriteMakefileArgs); diff --git a/README b/README new file mode 100644 index 0000000..8b58130 --- /dev/null +++ b/README @@ -0,0 +1,375 @@ +NAME + Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external + programs + +VERSION + version 0.48 + +SYNOPSIS + use Capture::Tiny ':all'; + + # capture from external command + + ($stdout, $stderr, $exit) = capture { + system( $cmd, @args ); + }; + + # capture from arbitrary code (Perl or external) + + ($stdout, $stderr, @result) = capture { + # your code here + }; + + # capture partial or merged output + + $stdout = capture_stdout { ... }; + $stderr = capture_stderr { ... }; + $merged = capture_merged { ... }; + + # tee output + + ($stdout, $stderr) = tee { + # your code here + }; + + $stdout = tee_stdout { ... }; + $stderr = tee_stderr { ... }; + $merged = tee_merged { ... }; + +DESCRIPTION + Capture::Tiny provides a simple, portable way to capture almost anything + sent to STDOUT or STDERR, regardless of whether it comes from Perl, from + XS code or from an external program. Optionally, output can be teed so + that it is captured while being passed through to the original + filehandles. Yes, it even works on Windows (usually). Stop guessing + which of a dozen capturing modules to use in any particular situation + and just use this one. + +USAGE + The following functions are available. None are exported by default. + + capture + ($stdout, $stderr, @result) = capture \&code; + $stdout = capture \&code; + + The "capture" function takes a code reference and returns what is sent + to STDOUT and STDERR as well as any return values from the code + reference. In scalar context, it returns only STDOUT. If no output was + received for a filehandle, it returns an empty string for that + filehandle. Regardless of calling context, all output is captured -- + nothing is passed to the existing filehandles. + + It is prototyped to take a subroutine reference as an argument. Thus, it + can be called in block form: + + ($stdout, $stderr) = capture { + # your code here ... + }; + + Note that the coderef is evaluated in list context. If you wish to force + scalar context on the return value, you must use the "scalar" keyword. + + ($stdout, $stderr, $count) = capture { + my @list = qw/one two three/; + return scalar @list; # $count will be 3 + }; + + Also note that within the coderef, the @_ variable will be empty. So + don't use arguments from a surrounding subroutine without copying them + to an array first: + + sub wont_work { + my ($stdout, $stderr) = capture { do_stuff( @_ ) }; # WRONG + ... + } + + sub will_work { + my @args = @_; + my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT + ... + } + + Captures are normally done to an anonymous temporary filehandle. To + capture via a named file (e.g. to externally monitor a long-running + capture), provide custom filehandles as a trailing list of option pairs: + + my $out_fh = IO::File->new("out.txt", "w+"); + my $err_fh = IO::File->new("out.txt", "w+"); + capture { ... } stdout => $out_fh, stderr => $err_fh; + + The filehandles must be read/write and seekable. Modifying the files or + filehandles during a capture operation will give unpredictable results. + Existing IO layers on them may be changed by the capture. + + When called in void context, "capture" saves memory and time by not + reading back from the capture handles. + + capture_stdout + ($stdout, @result) = capture_stdout \&code; + $stdout = capture_stdout \&code; + + The "capture_stdout" function works just like "capture" except only + STDOUT is captured. STDERR is not captured. + + capture_stderr + ($stderr, @result) = capture_stderr \&code; + $stderr = capture_stderr \&code; + + The "capture_stderr" function works just like "capture" except only + STDERR is captured. STDOUT is not captured. + + capture_merged + ($merged, @result) = capture_merged \&code; + $merged = capture_merged \&code; + + The "capture_merged" function works just like "capture" except STDOUT + and STDERR are merged. (Technically, STDERR is redirected to the same + capturing handle as STDOUT before executing the function.) + + Caution: STDOUT and STDERR output in the merged result are not + guaranteed to be properly ordered due to buffering. + + tee + ($stdout, $stderr, @result) = tee \&code; + $stdout = tee \&code; + + The "tee" function works just like "capture", except that output is + captured as well as passed on to the original STDOUT and STDERR. + + When called in void context, "tee" saves memory and time by not reading + back from the capture handles, except when the original STDOUT OR STDERR + were tied or opened to a scalar handle. + + tee_stdout + ($stdout, @result) = tee_stdout \&code; + $stdout = tee_stdout \&code; + + The "tee_stdout" function works just like "tee" except only STDOUT is + teed. STDERR is not teed (output goes to STDERR as usual). + + tee_stderr + ($stderr, @result) = tee_stderr \&code; + $stderr = tee_stderr \&code; + + The "tee_stderr" function works just like "tee" except only STDERR is + teed. STDOUT is not teed (output goes to STDOUT as usual). + + tee_merged + ($merged, @result) = tee_merged \&code; + $merged = tee_merged \&code; + + The "tee_merged" function works just like "capture_merged" except that + output is captured as well as passed on to STDOUT. + + Caution: STDOUT and STDERR output in the merged result are not + guaranteed to be properly ordered due to buffering. + +LIMITATIONS + Portability + Portability is a goal, not a guarantee. "tee" requires fork, except on + Windows where "system(1, @cmd)" is used instead. Not tested on any + particularly esoteric platforms yet. See the CPAN Testers Matrix + for test result by + platform. + + PerlIO layers + Capture::Tiny does its best to preserve PerlIO layers such as ':utf8' or + ':crlf' when capturing (only for Perl 5.8.1+) . Layers should be applied + to STDOUT or STDERR *before* the call to "capture" or "tee". This may + not work for tied filehandles (see below). + + Modifying filehandles before capturing + Generally speaking, you should do little or no manipulation of the + standard IO filehandles prior to using Capture::Tiny. In particular, + closing, reopening, localizing or tying standard filehandles prior to + capture may cause a variety of unexpected, undesirable and/or unreliable + behaviors, as described below. Capture::Tiny does its best to compensate + for these situations, but the results may not be what you desire. + + Closed filehandles + Capture::Tiny will work even if STDIN, STDOUT or STDERR have been + previously closed. However, since they will be reopened to capture or + tee output, any code within the captured block that depends on finding + them closed will, of course, not find them to be closed. If they started + closed, Capture::Tiny will close them again when the capture block + finishes. + + Note that this reopening will happen even for STDIN or a filehandle not + being captured to ensure that the filehandle used for capture is not + opened to file descriptor 0, as this causes problems on various + platforms. + + Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks + filehandles and also breaks tee() for undiagnosed reasons. So don't do + that. + + Localized filehandles + If code localizes any of Perl's standard filehandles before capturing, + the capture will affect the localized filehandles and not the original + ones. External system calls are not affected by localizing a filehandle + in Perl and will continue to send output to the original filehandles + (which will thus not be captured). + + Scalar filehandles + If STDOUT or STDERR are reopened to scalar filehandles prior to the call + to "capture" or "tee", then Capture::Tiny will override the output + filehandle for the duration of the "capture" or "tee" call and then, for + "tee", send captured output to the output filehandle after the capture + is complete. (Requires Perl 5.8) + + Capture::Tiny attempts to preserve the semantics of STDIN opened to a + scalar reference, but note that external processes will not be able to + read from such a handle. Capture::Tiny tries to ensure that external + processes will read from the null device instead, but this is not + guaranteed. + + Tied output filehandles + If STDOUT or STDERR are tied prior to the call to "capture" or "tee", + then Capture::Tiny will attempt to override the tie for the duration of + the "capture" or "tee" call and then send captured output to the tied + filehandle after the capture is complete. (Requires Perl 5.8) + + Capture::Tiny may not succeed resending UTF-8 encoded data to a tied + STDOUT or STDERR filehandle. Characters may appear as bytes. If the tied + filehandle is based on Tie::StdHandle, then Capture::Tiny will attempt + to determine appropriate layers like ":utf8" from the underlying + filehandle and do the right thing. + + Tied input filehandle + Capture::Tiny attempts to preserve the semantics of tied STDIN, but this + requires Perl 5.8 and is not entirely predictable. External processes + will not be able to read from such a handle. + + Unless having STDIN tied is crucial, it may be safest to localize STDIN + when capturing: + + my ($out, $err) = do { local *STDIN; capture { ... } }; + + Modifying filehandles during a capture + Attempting to modify STDIN, STDOUT or STDERR *during* "capture" or "tee" + is almost certainly going to cause problems. Don't do that. + + Forking inside a capture + Forks aren't portable. The behavior of filehandles during a fork is even + less so. If Capture::Tiny detects that a fork has occurred within a + capture, it will shortcut in the child process and return empty strings + for captures. Other problems may occur in the child or parent, as well. + Forking in a capture block is not recommended. + + Using threads + Filehandles are global. Mixing up I/O and captures in different threads + without coordination is going to cause problems. Besides, threads are + officially discouraged. + + Dropping privileges during a capture + If you drop privileges during a capture, temporary files created to + facilitate the capture may not be cleaned up afterwards. + + No support for Perl 5.8.0 + It's just too buggy when it comes to layers and UTF-8. Perl 5.8.1 or + later is recommended. + + Limited support for Perl 5.6 + Perl 5.6 predates PerlIO. UTF-8 data may not be captured correctly. + +ENVIRONMENT + PERL_CAPTURE_TINY_TIMEOUT + Capture::Tiny uses subprocesses internally for "tee". By default, + Capture::Tiny will timeout with an error if such subprocesses are not + ready to receive data within 30 seconds (or whatever is the value of + $Capture::Tiny::TIMEOUT). An alternate timeout may be specified by + setting the "PERL_CAPTURE_TINY_TIMEOUT" environment variable. Setting it + to zero will disable timeouts. NOTE, this does not timeout the code + reference being captured -- this only prevents Capture::Tiny itself from + hanging your process waiting for its child processes to be ready to + proceed. + +SEE ALSO + This module was inspired by IO::CaptureOutput, which provides similar + functionality without the ability to tee output and with more + complicated code and API. IO::CaptureOutput does not handle layers or + most of the unusual cases described in the "Limitations" section and I + no longer recommend it. + + There are many other CPAN modules that provide some sort of output + capture, albeit with various limitations that make them appropriate only + in particular circumstances. I'm probably missing some. The long list is + provided to show why I felt Capture::Tiny was necessary. + + * IO::Capture + + * IO::Capture::Extended + + * IO::CaptureOutput + + * IPC::Capture + + * IPC::Cmd + + * IPC::Open2 + + * IPC::Open3 + + * IPC::Open3::Simple + + * IPC::Open3::Utils + + * IPC::Run + + * IPC::Run::SafeHandles + + * IPC::Run::Simple + + * IPC::Run3 + + * IPC::System::Simple + + * Tee + + * IO::Tee + + * File::Tee + + * Filter::Handle + + * Tie::STDERR + + * Tie::STDOUT + + * Test::Output + +SUPPORT + Bugs / Feature Requests + Please report any bugs or feature requests through the issue tracker at + . You will be notified + automatically of any progress on your issue. + + Source Code + This is open source software. The code repository is available for + public review and contribution under the terms of the license. + + + + git clone https://github.com/dagolden/Capture-Tiny.git + +AUTHOR + David Golden + +CONTRIBUTORS + * Dagfinn Ilmari Mannsåker + + * David E. Wheeler + + * fecundf + + * Graham Knop + + * Peter Rabbitson + +COPYRIGHT AND LICENSE + This software is Copyright (c) 2009 by David Golden. + + This is free software, licensed under: + + The Apache License, Version 2.0, January 2004 + diff --git a/Todo b/Todo new file mode 100644 index 0000000..cec16db --- /dev/null +++ b/Todo @@ -0,0 +1,8 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +- Test utf8 output +- Test with curses diff --git a/cpanfile b/cpanfile new file mode 100644 index 0000000..3d5be8d --- /dev/null +++ b/cpanfile @@ -0,0 +1,50 @@ +requires "Carp" => "0"; +requires "Exporter" => "0"; +requires "File::Spec" => "0"; +requires "File::Temp" => "0"; +requires "IO::Handle" => "0"; +requires "Scalar::Util" => "0"; +requires "perl" => "5.006"; +requires "strict" => "0"; +requires "warnings" => "0"; + +on 'test' => sub { + requires "ExtUtils::MakeMaker" => "0"; + requires "File::Spec" => "0"; + requires "IO::File" => "0"; + requires "Test::More" => "0.62"; + requires "lib" => "0"; +}; + +on 'test' => sub { + recommends "CPAN::Meta" => "2.120900"; +}; + +on 'configure' => sub { + requires "ExtUtils::MakeMaker" => "6.17"; +}; + +on 'develop' => sub { + requires "Dist::Zilla" => "5"; + requires "Dist::Zilla::Plugin::OSPrereqs" => "0"; + requires "Dist::Zilla::Plugin::Prereqs" => "0"; + requires "Dist::Zilla::Plugin::ReleaseStatus::FromVersion" => "0"; + requires "Dist::Zilla::Plugin::RemovePrereqs" => "0"; + requires "Dist::Zilla::PluginBundle::DAGOLDEN" => "0.072"; + requires "File::Spec" => "0"; + requires "File::Temp" => "0"; + requires "IO::Handle" => "0"; + requires "IPC::Open3" => "0"; + requires "Pod::Coverage::TrustPod" => "0"; + requires "Pod::Wordlist" => "0"; + requires "Software::License::Apache_2_0" => "0"; + requires "Test::CPAN::Meta" => "0"; + requires "Test::MinimumVersion" => "0"; + requires "Test::More" => "0"; + requires "Test::Perl::Critic" => "0"; + requires "Test::Pod" => "1.41"; + requires "Test::Pod::Coverage" => "1.08"; + requires "Test::Portability::Files" => "0"; + requires "Test::Spelling" => "0.12"; + requires "Test::Version" => "1"; +}; diff --git a/dist.ini b/dist.ini new file mode 100644 index 0000000..699b28a --- /dev/null +++ b/dist.ini @@ -0,0 +1,29 @@ +name = Capture-Tiny +author = David Golden +license = Apache_2_0 +copyright_holder = David Golden +copyright_year = 2009 + +[@DAGOLDEN] +:version = 0.072 +stopwords = UTF +stopwords = seekable +stopwords = prototyped +stopwords = resending +stopwords = undiagnosed + +[ReleaseStatus::FromVersion] +testing = second_decimal_odd + +[OSPrereqs / MSWin32] +Win32API::File = 0 + +[RemovePrereqs] +remove = PerlIO +remove = PerlIO::scalar +remove = Test::Differences +; tests optionally require 5.008 +remove = perl + +[Prereqs] +perl = 5.006 diff --git a/examples/rt-58208.pl b/examples/rt-58208.pl new file mode 100644 index 0000000..dd5e164 --- /dev/null +++ b/examples/rt-58208.pl @@ -0,0 +1,11 @@ +use Capture::Tiny qw[ capture ]; + +my ( $out, $err ) = + eval { capture { print STDERR "hello\n"; print STDOUT "there\n"; die("foo\n" ) } }; + +print STDERR "STDERR:\nout=$out\nerr=$err\n\$@=$@"; +print STDOUT "STDOUT:\nout=$out\nerr=$err\n\$@=$@"; + +open FILE, '>ttt.log' or die( "error opening logfile\n" ); +print FILE "FILE:\nout=$out\nerr=$err\n\$@=$@\n"; +close FILE; diff --git a/examples/tee.pl b/examples/tee.pl new file mode 100644 index 0000000..14839a9 --- /dev/null +++ b/examples/tee.pl @@ -0,0 +1,18 @@ +use strict; +use warnings; + +use Capture::Tiny qw/capture tee/; + +print "Type some text. Type 'exit' to quit\n"; +my ($out, $err) = tee { + while (<>) { + last if /^exit$/; + print "Echoing to STDOUT: $_"; + print STDERR "Echoing to STDERR: $_"; + } +}; + +print "\nCaptured STDOUT was:\n" . ( defined $out ? $out : 'undef' ); +print "\nCaptured STDERR was:\n" . ( defined $err ? $err : 'undef' ); + + diff --git a/lib/Capture/Tiny.pm b/lib/Capture/Tiny.pm new file mode 100644 index 0000000..2a5af95 --- /dev/null +++ b/lib/Capture/Tiny.pm @@ -0,0 +1,901 @@ +use 5.006; +use strict; +use warnings; +package Capture::Tiny; +# ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs +our $VERSION = '0.48'; +use Carp (); +use Exporter (); +use IO::Handle (); +use File::Spec (); +use File::Temp qw/tempfile tmpnam/; +use Scalar::Util qw/reftype blessed/; +# Get PerlIO or fake it +BEGIN { + local $@; + eval { require PerlIO; PerlIO->can('get_layers') } + or *PerlIO::get_layers = sub { return () }; +} + +#--------------------------------------------------------------------------# +# create API subroutines and export them +# [do STDOUT flag, do STDERR flag, do merge flag, do tee flag] +#--------------------------------------------------------------------------# + +my %api = ( + capture => [1,1,0,0], + capture_stdout => [1,0,0,0], + capture_stderr => [0,1,0,0], + capture_merged => [1,1,1,0], + tee => [1,1,0,1], + tee_stdout => [1,0,0,1], + tee_stderr => [0,1,0,1], + tee_merged => [1,1,1,1], +); + +for my $sub ( keys %api ) { + my $args = join q{, }, @{$api{$sub}}; + eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic +} + +our @ISA = qw/Exporter/; +our @EXPORT_OK = keys %api; +our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); + +#--------------------------------------------------------------------------# +# constants and fixtures +#--------------------------------------------------------------------------# + +my $IS_WIN32 = $^O eq 'MSWin32'; + +##our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG}; +## +##my $DEBUGFH; +##open $DEBUGFH, "> DEBUG" if $DEBUG; +## +##*_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0}; + +our $TIMEOUT = 30; + +#--------------------------------------------------------------------------# +# command to tee output -- the argument is a filename that must +# be opened to signal that the process is ready to receive input. +# This is annoying, but seems to be the best that can be done +# as a simple, portable IPC technique +#--------------------------------------------------------------------------# +my @cmd = ($^X, '-C0', '-e', <<'HERE'); +use Fcntl; +$SIG{HUP}=sub{exit}; +if ( my $fn=shift ) { + sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!; + print {$fh} $$; + close $fh; +} +my $buf; while (sysread(STDIN, $buf, 2048)) { + syswrite(STDOUT, $buf); syswrite(STDERR, $buf); +} +HERE + +#--------------------------------------------------------------------------# +# filehandle manipulation +#--------------------------------------------------------------------------# + +sub _relayer { + my ($fh, $apply_layers) = @_; + # _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n"); + + # eliminate pseudo-layers + binmode( $fh, ":raw" ); + # strip off real layers until only :unix is left + while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) { + binmode( $fh, ":pop" ); + } + # apply other layers + my @to_apply = @$apply_layers; + shift @to_apply; # eliminate initial :unix + # _debug("# applying layers (unix @to_apply) to @{[fileno $fh]}\n"); + binmode($fh, ":" . join(":",@to_apply)); +} + +sub _name { + my $glob = shift; + no strict 'refs'; ## no critic + return *{$glob}{NAME}; +} + +sub _open { + open $_[0], $_[1] or Carp::confess "Error from open(" . join(q{, }, @_) . "): $!"; + # _debug( "# open " . join( ", " , map { defined $_ ? _name($_) : 'undef' } @_ ) . " as " . fileno( $_[0] ) . "\n" ); +} + +sub _close { + # _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' ) . " on " . fileno( $_[0] ) . "\n" ); + close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!"; +} + +my %dup; # cache this so STDIN stays fd0 +my %proxy_count; +sub _proxy_std { + my %proxies; + if ( ! defined fileno STDIN ) { + $proxy_count{stdin}++; + if (defined $dup{stdin}) { + _open \*STDIN, "<&=" . fileno($dup{stdin}); + # _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); + } + else { + _open \*STDIN, "<" . File::Spec->devnull; + # _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); + _open $dup{stdin} = IO::Handle->new, "<&=STDIN"; + } + $proxies{stdin} = \*STDIN; + binmode(STDIN, ':utf8') if $] >= 5.008; ## no critic + } + if ( ! defined fileno STDOUT ) { + $proxy_count{stdout}++; + if (defined $dup{stdout}) { + _open \*STDOUT, ">&=" . fileno($dup{stdout}); + # _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); + } + else { + _open \*STDOUT, ">" . File::Spec->devnull; + # _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); + _open $dup{stdout} = IO::Handle->new, ">&=STDOUT"; + } + $proxies{stdout} = \*STDOUT; + binmode(STDOUT, ':utf8') if $] >= 5.008; ## no critic + } + if ( ! defined fileno STDERR ) { + $proxy_count{stderr}++; + if (defined $dup{stderr}) { + _open \*STDERR, ">&=" . fileno($dup{stderr}); + # _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); + } + else { + _open \*STDERR, ">" . File::Spec->devnull; + # _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); + _open $dup{stderr} = IO::Handle->new, ">&=STDERR"; + } + $proxies{stderr} = \*STDERR; + binmode(STDERR, ':utf8') if $] >= 5.008; ## no critic + } + return %proxies; +} + +sub _unproxy { + my (%proxies) = @_; + # _debug( "# unproxying: " . join(" ", keys %proxies) . "\n" ); + for my $p ( keys %proxies ) { + $proxy_count{$p}--; + # _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" ); + if ( ! $proxy_count{$p} ) { + _close $proxies{$p}; + _close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup + delete $dup{$p}; + } + } +} + +sub _copy_std { + my %handles; + for my $h ( qw/stdout stderr stdin/ ) { + next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied + my $redir = $h eq 'stdin' ? "<&" : ">&"; + _open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN" + } + return \%handles; +} + +# In some cases we open all (prior to forking) and in others we only open +# the output handles (setting up redirection) +sub _open_std { + my ($handles) = @_; + _open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin}; + _open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout}; + _open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr}; +} + +#--------------------------------------------------------------------------# +# private subs +#--------------------------------------------------------------------------# + +sub _start_tee { + my ($which, $stash) = @_; # $which is "stdout" or "stderr" + # setup pipes + $stash->{$_}{$which} = IO::Handle->new for qw/tee reader/; + pipe $stash->{reader}{$which}, $stash->{tee}{$which}; + # _debug( "# pipe for $which\: " . _name($stash->{tee}{$which}) . " " . fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which}) . " " . fileno( $stash->{reader}{$which}) . "\n" ); + select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush + # setup desired redirection for parent and child + $stash->{new}{$which} = $stash->{tee}{$which}; + $stash->{child}{$which} = { + stdin => $stash->{reader}{$which}, + stdout => $stash->{old}{$which}, + stderr => $stash->{capture}{$which}, + }; + # flag file is used to signal the child is ready + $stash->{flag_files}{$which} = scalar( tmpnam() ) . $$; + # execute @cmd as a separate process + if ( $IS_WIN32 ) { + my $old_eval_err=$@; + undef $@; + + eval "use Win32API::File qw/GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ "; + # _debug( "# Win32API::File loaded\n") unless $@; + my $os_fhandle = GetOsFHandle( $stash->{tee}{$which} ); + # _debug( "# Couldn't get OS handle: " . fileLastError() . "\n") if ! defined $os_fhandle || $os_fhandle == INVALID_HANDLE_VALUE(); + my $result = SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0); + # _debug( $result ? "# set no-inherit flag on $which tee\n" : ("# can't disable tee handle flag inherit: " . fileLastError() . "\n")); + _open_std( $stash->{child}{$which} ); + $stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which}); + # not restoring std here as it all gets redirected again shortly anyway + $@=$old_eval_err; + } + else { # use fork + _fork_exec( $which, $stash ); + } +} + +sub _fork_exec { + my ($which, $stash) = @_; # $which is "stdout" or "stderr" + my $pid = fork; + if ( not defined $pid ) { + Carp::confess "Couldn't fork(): $!"; + } + elsif ($pid == 0) { # child + # _debug( "# in child process ...\n" ); + untie *STDIN; untie *STDOUT; untie *STDERR; + _close $stash->{tee}{$which}; + # _debug( "# redirecting handles in child ...\n" ); + _open_std( $stash->{child}{$which} ); + # _debug( "# calling exec on command ...\n" ); + exec @cmd, $stash->{flag_files}{$which}; + } + $stash->{pid}{$which} = $pid +} + +my $have_usleep = eval "use Time::HiRes 'usleep'; 1"; +sub _files_exist { + return 1 if @_ == grep { -f } @_; + Time::HiRes::usleep(1000) if $have_usleep; + return 0; +} + +sub _wait_for_tees { + my ($stash) = @_; + my $start = time; + my @files = values %{$stash->{flag_files}}; + my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT} + ? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT; + 1 until _files_exist(@files) || ($timeout && (time - $start > $timeout)); + Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files); + unlink $_ for @files; +} + +sub _kill_tees { + my ($stash) = @_; + if ( $IS_WIN32 ) { + # _debug( "# closing handles\n"); + close($_) for values %{ $stash->{tee} }; + # _debug( "# waiting for subprocesses to finish\n"); + my $start = time; + 1 until wait == -1 || (time - $start > 30); + } + else { + _close $_ for values %{ $stash->{tee} }; + waitpid $_, 0 for values %{ $stash->{pid} }; + } +} + +sub _slurp { + my ($name, $stash) = @_; + my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/; + # _debug( "# slurping captured $name from " . fileno($fh) . " at pos $pos with layers: @{[PerlIO::get_layers($fh)]}\n"); + seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n"; + my $text = do { local $/; scalar readline $fh }; + return defined($text) ? $text : ""; +} + +#--------------------------------------------------------------------------# +# _capture_tee() -- generic main sub for capturing or teeing +#--------------------------------------------------------------------------# + +sub _capture_tee { + # _debug( "# starting _capture_tee with (@_)...\n" ); + my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_; + my %do = ($do_stdout ? (stdout => 1) : (), $do_stderr ? (stderr => 1) : ()); + Carp::confess("Custom capture options must be given as key/value pairs\n") + unless @opts % 2 == 0; + my $stash = { capture => { @opts } }; + for ( keys %{$stash->{capture}} ) { + my $fh = $stash->{capture}{$_}; + Carp::confess "Custom handle for $_ must be seekable\n" + unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable")); + } + # save existing filehandles and setup captures + local *CT_ORIG_STDIN = *STDIN ; + local *CT_ORIG_STDOUT = *STDOUT; + local *CT_ORIG_STDERR = *STDERR; + # find initial layers + my %layers = ( + stdin => [PerlIO::get_layers(\*STDIN) ], + stdout => [PerlIO::get_layers(\*STDOUT, output => 1)], + stderr => [PerlIO::get_layers(\*STDERR, output => 1)], + ); + # _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; + # get layers from underlying glob of tied filehandles if we can + # (this only works for things that work like Tie::StdHandle) + $layers{stdout} = [PerlIO::get_layers(tied *STDOUT)] + if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB'); + $layers{stderr} = [PerlIO::get_layers(tied *STDERR)] + if tied(*STDERR) && (reftype tied *STDERR eq 'GLOB'); + # _debug( "# tied object corrected layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; + # bypass scalar filehandles and tied handles + # localize scalar STDIN to get a proxy to pick up FD0, then restore later to CT_ORIG_STDIN + my %localize; + $localize{stdin}++, local(*STDIN) + if grep { $_ eq 'scalar' } @{$layers{stdin}}; + $localize{stdout}++, local(*STDOUT) + if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}}; + $localize{stderr}++, local(*STDERR) + if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}}; + $localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0") + if tied *STDIN && $] >= 5.008; + $localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1") + if $do_stdout && tied *STDOUT && $] >= 5.008; + $localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2") + if ($do_stderr || $do_merge) && tied *STDERR && $] >= 5.008; + # _debug( "# localized $_\n" ) for keys %localize; + # proxy any closed/localized handles so we don't use fds 0, 1 or 2 + my %proxy_std = _proxy_std(); + # _debug( "# proxy std: @{ [%proxy_std] }\n" ); + # update layers after any proxying + $layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout}; + $layers{stderr} = [PerlIO::get_layers(\*STDERR, output => 1)] if $proxy_std{stderr}; + # _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; + # store old handles and setup handles for capture + $stash->{old} = _copy_std(); + $stash->{new} = { %{$stash->{old}} }; # default to originals + for ( keys %do ) { + $stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new); + seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n"; + $stash->{pos}{$_} = tell $stash->{capture}{$_}; + # _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" ); + _start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new} + } + _wait_for_tees( $stash ) if $do_tee; + # finalize redirection + $stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge; + # _debug( "# redirecting in parent ...\n" ); + _open_std( $stash->{new} ); + # execute user provided code + my ($exit_code, $inner_error, $outer_error, $orig_pid, @result); + { + $orig_pid = $$; + local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN + # _debug( "# finalizing layers ...\n" ); + _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; + _relayer(\*STDERR, $layers{stderr}) if $do_stderr; + # _debug( "# running code $code ...\n" ); + my $old_eval_err=$@; + undef $@; + eval { @result = $code->(); $inner_error = $@ }; + $exit_code = $?; # save this for later + $outer_error = $@; # save this for later + STDOUT->flush if $do_stdout; + STDERR->flush if $do_stderr; + $@ = $old_eval_err; + } + # restore prior filehandles and shut down tees + # _debug( "# restoring filehandles ...\n" ); + _open_std( $stash->{old} ); + _close( $_ ) for values %{$stash->{old}}; # don't leak fds + # shouldn't need relayering originals, but see rt.perl.org #114404 + _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; + _relayer(\*STDERR, $layers{stderr}) if $do_stderr; + _unproxy( %proxy_std ); + # _debug( "# killing tee subprocesses ...\n" ) if $do_tee; + _kill_tees( $stash ) if $do_tee; + # return captured output, but shortcut in void context + # unless we have to echo output to tied/scalar handles; + my %got; + if ( $orig_pid == $$ and ( defined wantarray or ($do_tee && keys %localize) ) ) { + for ( keys %do ) { + _relayer($stash->{capture}{$_}, $layers{$_}); + $got{$_} = _slurp($_, $stash); + # _debug("# slurped " . length($got{$_}) . " bytes from $_\n"); + } + print CT_ORIG_STDOUT $got{stdout} + if $do_stdout && $do_tee && $localize{stdout}; + print CT_ORIG_STDERR $got{stderr} + if $do_stderr && $do_tee && $localize{stderr}; + } + $? = $exit_code; + $@ = $inner_error if $inner_error; + die $outer_error if $outer_error; + # _debug( "# ending _capture_tee with (@_)...\n" ); + return unless defined wantarray; + my @return; + push @return, $got{stdout} if $do_stdout; + push @return, $got{stderr} if $do_stderr && ! $do_merge; + push @return, @result; + return wantarray ? @return : $return[0]; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs + +=head1 VERSION + +version 0.48 + +=head1 SYNOPSIS + + use Capture::Tiny ':all'; + + # capture from external command + + ($stdout, $stderr, $exit) = capture { + system( $cmd, @args ); + }; + + # capture from arbitrary code (Perl or external) + + ($stdout, $stderr, @result) = capture { + # your code here + }; + + # capture partial or merged output + + $stdout = capture_stdout { ... }; + $stderr = capture_stderr { ... }; + $merged = capture_merged { ... }; + + # tee output + + ($stdout, $stderr) = tee { + # your code here + }; + + $stdout = tee_stdout { ... }; + $stderr = tee_stderr { ... }; + $merged = tee_merged { ... }; + +=head1 DESCRIPTION + +Capture::Tiny provides a simple, portable way to capture almost anything sent +to STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or +from an external program. Optionally, output can be teed so that it is +captured while being passed through to the original filehandles. Yes, it even +works on Windows (usually). Stop guessing which of a dozen capturing modules +to use in any particular situation and just use this one. + +=head1 USAGE + +The following functions are available. None are exported by default. + +=head2 capture + + ($stdout, $stderr, @result) = capture \&code; + $stdout = capture \&code; + +The C function takes a code reference and returns what is sent to +STDOUT and STDERR as well as any return values from the code reference. In +scalar context, it returns only STDOUT. If no output was received for a +filehandle, it returns an empty string for that filehandle. Regardless of calling +context, all output is captured -- nothing is passed to the existing filehandles. + +It is prototyped to take a subroutine reference as an argument. Thus, it +can be called in block form: + + ($stdout, $stderr) = capture { + # your code here ... + }; + +Note that the coderef is evaluated in list context. If you wish to force +scalar context on the return value, you must use the C keyword. + + ($stdout, $stderr, $count) = capture { + my @list = qw/one two three/; + return scalar @list; # $count will be 3 + }; + +Also note that within the coderef, the C<@_> variable will be empty. So don't +use arguments from a surrounding subroutine without copying them to an array +first: + + sub wont_work { + my ($stdout, $stderr) = capture { do_stuff( @_ ) }; # WRONG + ... + } + + sub will_work { + my @args = @_; + my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT + ... + } + +Captures are normally done to an anonymous temporary filehandle. To +capture via a named file (e.g. to externally monitor a long-running capture), +provide custom filehandles as a trailing list of option pairs: + + my $out_fh = IO::File->new("out.txt", "w+"); + my $err_fh = IO::File->new("out.txt", "w+"); + capture { ... } stdout => $out_fh, stderr => $err_fh; + +The filehandles must be read/write and seekable. Modifying the files or +filehandles during a capture operation will give unpredictable results. +Existing IO layers on them may be changed by the capture. + +When called in void context, C saves memory and time by +not reading back from the capture handles. + +=head2 capture_stdout + + ($stdout, @result) = capture_stdout \&code; + $stdout = capture_stdout \&code; + +The C function works just like C except only +STDOUT is captured. STDERR is not captured. + +=head2 capture_stderr + + ($stderr, @result) = capture_stderr \&code; + $stderr = capture_stderr \&code; + +The C function works just like C except only +STDERR is captured. STDOUT is not captured. + +=head2 capture_merged + + ($merged, @result) = capture_merged \&code; + $merged = capture_merged \&code; + +The C function works just like C except STDOUT and +STDERR are merged. (Technically, STDERR is redirected to the same capturing +handle as STDOUT before executing the function.) + +Caution: STDOUT and STDERR output in the merged result are not guaranteed to be +properly ordered due to buffering. + +=head2 tee + + ($stdout, $stderr, @result) = tee \&code; + $stdout = tee \&code; + +The C function works just like C, except that output is captured +as well as passed on to the original STDOUT and STDERR. + +When called in void context, C saves memory and time by +not reading back from the capture handles, except when the +original STDOUT OR STDERR were tied or opened to a scalar +handle. + +=head2 tee_stdout + + ($stdout, @result) = tee_stdout \&code; + $stdout = tee_stdout \&code; + +The C function works just like C except only +STDOUT is teed. STDERR is not teed (output goes to STDERR as usual). + +=head2 tee_stderr + + ($stderr, @result) = tee_stderr \&code; + $stderr = tee_stderr \&code; + +The C function works just like C except only +STDERR is teed. STDOUT is not teed (output goes to STDOUT as usual). + +=head2 tee_merged + + ($merged, @result) = tee_merged \&code; + $merged = tee_merged \&code; + +The C function works just like C except that output +is captured as well as passed on to STDOUT. + +Caution: STDOUT and STDERR output in the merged result are not guaranteed to be +properly ordered due to buffering. + +=head1 LIMITATIONS + +=head2 Portability + +Portability is a goal, not a guarantee. C requires fork, except on +Windows where C is used instead. Not tested on any +particularly esoteric platforms yet. See the +L +for test result by platform. + +=head2 PerlIO layers + +Capture::Tiny does its best to preserve PerlIO layers such as ':utf8' or +':crlf' when capturing (only for Perl 5.8.1+) . Layers should be applied to +STDOUT or STDERR I the call to C or C. This may not work +for tied filehandles (see below). + +=head2 Modifying filehandles before capturing + +Generally speaking, you should do little or no manipulation of the standard IO +filehandles prior to using Capture::Tiny. In particular, closing, reopening, +localizing or tying standard filehandles prior to capture may cause a variety of +unexpected, undesirable and/or unreliable behaviors, as described below. +Capture::Tiny does its best to compensate for these situations, but the +results may not be what you desire. + +=head3 Closed filehandles + +Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously +closed. However, since they will be reopened to capture or tee output, any +code within the captured block that depends on finding them closed will, of +course, not find them to be closed. If they started closed, Capture::Tiny will +close them again when the capture block finishes. + +Note that this reopening will happen even for STDIN or a filehandle not being +captured to ensure that the filehandle used for capture is not opened to file +descriptor 0, as this causes problems on various platforms. + +Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles +and also breaks tee() for undiagnosed reasons. So don't do that. + +=head3 Localized filehandles + +If code localizes any of Perl's standard filehandles before capturing, the capture +will affect the localized filehandles and not the original ones. External system +calls are not affected by localizing a filehandle in Perl and will continue +to send output to the original filehandles (which will thus not be captured). + +=head3 Scalar filehandles + +If STDOUT or STDERR are reopened to scalar filehandles prior to the call to +C or C, then Capture::Tiny will override the output filehandle for +the duration of the C or C call and then, for C, send captured +output to the output filehandle after the capture is complete. (Requires Perl +5.8) + +Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar +reference, but note that external processes will not be able to read from such +a handle. Capture::Tiny tries to ensure that external processes will read from +the null device instead, but this is not guaranteed. + +=head3 Tied output filehandles + +If STDOUT or STDERR are tied prior to the call to C or C, then +Capture::Tiny will attempt to override the tie for the duration of the +C or C call and then send captured output to the tied filehandle after +the capture is complete. (Requires Perl 5.8) + +Capture::Tiny may not succeed resending UTF-8 encoded data to a tied +STDOUT or STDERR filehandle. Characters may appear as bytes. If the tied filehandle +is based on L, then Capture::Tiny will attempt to determine +appropriate layers like C<:utf8> from the underlying filehandle and do the right +thing. + +=head3 Tied input filehandle + +Capture::Tiny attempts to preserve the semantics of tied STDIN, but this +requires Perl 5.8 and is not entirely predictable. External processes +will not be able to read from such a handle. + +Unless having STDIN tied is crucial, it may be safest to localize STDIN when +capturing: + + my ($out, $err) = do { local *STDIN; capture { ... } }; + +=head2 Modifying filehandles during a capture + +Attempting to modify STDIN, STDOUT or STDERR I C or C is +almost certainly going to cause problems. Don't do that. + +=head3 Forking inside a capture + +Forks aren't portable. The behavior of filehandles during a fork is even +less so. If Capture::Tiny detects that a fork has occurred within a +capture, it will shortcut in the child process and return empty strings for +captures. Other problems may occur in the child or parent, as well. +Forking in a capture block is not recommended. + +=head3 Using threads + +Filehandles are global. Mixing up I/O and captures in different threads +without coordination is going to cause problems. Besides, threads are +officially discouraged. + +=head3 Dropping privileges during a capture + +If you drop privileges during a capture, temporary files created to +facilitate the capture may not be cleaned up afterwards. + +=head2 No support for Perl 5.8.0 + +It's just too buggy when it comes to layers and UTF-8. Perl 5.8.1 or later +is recommended. + +=head2 Limited support for Perl 5.6 + +Perl 5.6 predates PerlIO. UTF-8 data may not be captured correctly. + +=head1 ENVIRONMENT + +=head2 PERL_CAPTURE_TINY_TIMEOUT + +Capture::Tiny uses subprocesses internally for C. By default, +Capture::Tiny will timeout with an error if such subprocesses are not ready to +receive data within 30 seconds (or whatever is the value of +C<$Capture::Tiny::TIMEOUT>). An alternate timeout may be specified by setting +the C environment variable. Setting it to zero will +disable timeouts. B, this does not timeout the code reference being +captured -- this only prevents Capture::Tiny itself from hanging your process +waiting for its child processes to be ready to proceed. + +=head1 SEE ALSO + +This module was inspired by L, which provides +similar functionality without the ability to tee output and with more +complicated code and API. L does not handle layers +or most of the unusual cases described in the L section and +I no longer recommend it. + +There are many other CPAN modules that provide some sort of output capture, +albeit with various limitations that make them appropriate only in particular +circumstances. I'm probably missing some. The long list is provided to show +why I felt Capture::Tiny was necessary. + +=over 4 + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=back + +=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + +=head1 SUPPORT + +=head2 Bugs / Feature Requests + +Please report any bugs or feature requests through the issue tracker +at L. +You will be notified automatically of any progress on your issue. + +=head2 Source Code + +This is open source software. The code repository is available for +public review and contribution under the terms of the license. + +L + + git clone https://github.com/dagolden/Capture-Tiny.git + +=head1 AUTHOR + +David Golden + +=head1 CONTRIBUTORS + +=for stopwords Dagfinn Ilmari Mannsåker David E. Wheeler fecundf Graham Knop Peter Rabbitson + +=over 4 + +=item * + +Dagfinn Ilmari Mannsåker + +=item * + +David E. Wheeler + +=item * + +fecundf + +=item * + +Graham Knop + +=item * + +Peter Rabbitson + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2009 by David Golden. + +This is free software, licensed under: + + The Apache License, Version 2.0, January 2004 + +=cut diff --git a/perlcritic.rc b/perlcritic.rc new file mode 100644 index 0000000..bcbbb45 --- /dev/null +++ b/perlcritic.rc @@ -0,0 +1,26 @@ +severity = 5 +verbose = 8 + +[Variables::ProhibitPunctuationVars] +allow = $@ $! + +[TestingAndDebugging::ProhibitNoStrict] +allow = refs + +[Variables::ProhibitEvilVariables] +variables = $DB::single + +# Turn these off +[-BuiltinFunctions::ProhibitStringyEval] +[-ControlStructures::ProhibitPostfixControls] +[-ControlStructures::ProhibitUnlessBlocks] +[-Documentation::RequirePodSections] +[-InputOutput::ProhibitInteractiveTest] +[-References::ProhibitDoubleSigils] +[-RegularExpressions::RequireExtendedFormatting] +[-InputOutput::ProhibitTwoArgOpen] +[-Modules::ProhibitEvilModules] + +# Turn this on +[Lax::ProhibitStringyEval::ExceptForRequire] + diff --git a/t/00-report-prereqs.dd b/t/00-report-prereqs.dd new file mode 100644 index 0000000..3a4465a --- /dev/null +++ b/t/00-report-prereqs.dd @@ -0,0 +1,60 @@ +do { my $x = { + 'configure' => { + 'requires' => { + 'ExtUtils::MakeMaker' => '6.17' + } + }, + 'develop' => { + 'requires' => { + 'Dist::Zilla' => '5', + 'Dist::Zilla::Plugin::OSPrereqs' => '0', + 'Dist::Zilla::Plugin::Prereqs' => '0', + 'Dist::Zilla::Plugin::ReleaseStatus::FromVersion' => '0', + 'Dist::Zilla::Plugin::RemovePrereqs' => '0', + 'Dist::Zilla::PluginBundle::DAGOLDEN' => '0.072', + 'File::Spec' => '0', + 'File::Temp' => '0', + 'IO::Handle' => '0', + 'IPC::Open3' => '0', + 'Pod::Coverage::TrustPod' => '0', + 'Pod::Wordlist' => '0', + 'Software::License::Apache_2_0' => '0', + 'Test::CPAN::Meta' => '0', + 'Test::MinimumVersion' => '0', + 'Test::More' => '0', + 'Test::Perl::Critic' => '0', + 'Test::Pod' => '1.41', + 'Test::Pod::Coverage' => '1.08', + 'Test::Portability::Files' => '0', + 'Test::Spelling' => '0.12', + 'Test::Version' => '1' + } + }, + 'runtime' => { + 'requires' => { + 'Carp' => '0', + 'Exporter' => '0', + 'File::Spec' => '0', + 'File::Temp' => '0', + 'IO::Handle' => '0', + 'Scalar::Util' => '0', + 'perl' => '5.006', + 'strict' => '0', + 'warnings' => '0' + } + }, + 'test' => { + 'recommends' => { + 'CPAN::Meta' => '2.120900' + }, + 'requires' => { + 'ExtUtils::MakeMaker' => '0', + 'File::Spec' => '0', + 'IO::File' => '0', + 'Test::More' => '0.62', + 'lib' => '0' + } + } + }; + $x; + } \ No newline at end of file diff --git a/t/00-report-prereqs.t b/t/00-report-prereqs.t new file mode 100644 index 0000000..c72183a --- /dev/null +++ b/t/00-report-prereqs.t @@ -0,0 +1,193 @@ +#!perl + +use strict; +use warnings; + +# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.027 + +use Test::More tests => 1; + +use ExtUtils::MakeMaker; +use File::Spec; + +# from $version::LAX +my $lax_version_re = + qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? + | + (?:\.[0-9]+) (?:_[0-9]+)? + ) | (?: + v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? + | + (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? + ) + )/x; + +# hide optional CPAN::Meta modules from prereq scanner +# and check if they are available +my $cpan_meta = "CPAN::Meta"; +my $cpan_meta_pre = "CPAN::Meta::Prereqs"; +my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic + +# Verify requirements? +my $DO_VERIFY_PREREQS = 1; + +sub _max { + my $max = shift; + $max = ( $_ > $max ) ? $_ : $max for @_; + return $max; +} + +sub _merge_prereqs { + my ($collector, $prereqs) = @_; + + # CPAN::Meta::Prereqs object + if (ref $collector eq $cpan_meta_pre) { + return $collector->with_merged_prereqs( + CPAN::Meta::Prereqs->new( $prereqs ) + ); + } + + # Raw hashrefs + for my $phase ( keys %$prereqs ) { + for my $type ( keys %{ $prereqs->{$phase} } ) { + for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { + $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; + } + } + } + + return $collector; +} + +my @include = qw( + +); + +my @exclude = qw( + +); + +# Add static prereqs to the included modules list +my $static_prereqs = do './t/00-report-prereqs.dd'; + +# Merge all prereqs (either with ::Prereqs or a hashref) +my $full_prereqs = _merge_prereqs( + ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), + $static_prereqs +); + +# Add dynamic prereqs to the included modules list (if we can) +my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; +my $cpan_meta_error; +if ( $source && $HAS_CPAN_META + && (my $meta = eval { CPAN::Meta->load_file($source) } ) +) { + $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); +} +else { + $cpan_meta_error = $@; # capture error from CPAN::Meta->load_file($source) + $source = 'static metadata'; +} + +my @full_reports; +my @dep_errors; +my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; + +# Add static includes into a fake section +for my $mod (@include) { + $req_hash->{other}{modules}{$mod} = 0; +} + +for my $phase ( qw(configure build test runtime develop other) ) { + next unless $req_hash->{$phase}; + next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); + + for my $type ( qw(requires recommends suggests conflicts modules) ) { + next unless $req_hash->{$phase}{$type}; + + my $title = ucfirst($phase).' '.ucfirst($type); + my @reports = [qw/Module Want Have/]; + + for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { + next if $mod eq 'perl'; + next if grep { $_ eq $mod } @exclude; + + my $file = $mod; + $file =~ s{::}{/}g; + $file .= ".pm"; + my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; + + my $want = $req_hash->{$phase}{$type}{$mod}; + $want = "undef" unless defined $want; + $want = "any" if !$want && $want == 0; + + my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; + + if ($prefix) { + my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); + $have = "undef" unless defined $have; + push @reports, [$mod, $want, $have]; + + if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { + if ( $have !~ /\A$lax_version_re\z/ ) { + push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; + } + elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { + push @dep_errors, "$mod version '$have' is not in required range '$want'"; + } + } + } + else { + push @reports, [$mod, $want, "missing"]; + + if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { + push @dep_errors, "$mod is not installed ($req_string)"; + } + } + } + + if ( @reports ) { + push @full_reports, "=== $title ===\n\n"; + + my $ml = _max( map { length $_->[0] } @reports ); + my $wl = _max( map { length $_->[1] } @reports ); + my $hl = _max( map { length $_->[2] } @reports ); + + if ($type eq 'modules') { + splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; + } + else { + splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; + push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; + } + + push @full_reports, "\n"; + } + } +} + +if ( @full_reports ) { + diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; +} + +if ( $cpan_meta_error || @dep_errors ) { + diag "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n"; +} + +if ( $cpan_meta_error ) { + my ($orig_source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; + diag "\nCPAN::Meta->load_file('$orig_source') failed with: $cpan_meta_error\n"; +} + +if ( @dep_errors ) { + diag join("\n", + "\nThe following REQUIRED prerequisites were not satisfied:\n", + @dep_errors, + "\n" + ); +} + +pass; + +# vim: ts=4 sts=4 sw=4 et: diff --git a/t/01-Capture-Tiny.t b/t/01-Capture-Tiny.t new file mode 100644 index 0000000..eb0cd5a --- /dev/null +++ b/t/01-Capture-Tiny.t @@ -0,0 +1,37 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; + +use Test::More 0.62; + +my @api = qw( + capture + capture_stdout + capture_stderr + capture_merged + tee + tee_stdout + tee_stderr + tee_merged +); + +plan tests => 2 + 2 * @api; + +if ( $] eq '5.008' ) { + BAIL_OUT("OS unsupported: Perl 5.8.0 is too buggy for Capture::Tiny"); +} + +require_ok( 'Capture::Tiny' ); + +can_ok('Capture::Tiny', $_) for @api; + +ok( eval "package Foo; use Capture::Tiny ':all'; 1", "import ':all' to Foo" ); + +can_ok('Foo', $_) for @api; + +exit 0; diff --git a/t/02-capture.t b/t/02-capture.t new file mode 100644 index 0000000..a70e3b1 --- /dev/null +++ b/t/02-capture.t @@ -0,0 +1,29 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/next_fd/; +use Cases qw/run_test/; + +plan 'no_plan'; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; + +my $fd = next_fd; + +run_test('capture'); +run_test('capture_scalar'); +run_test('capture_stdout'); +run_test('capture_stderr'); +run_test('capture_merged'); + +is( next_fd, $fd, "no file descriptors leaked" ); + +exit 0; diff --git a/t/03-tee.t b/t/03-tee.t new file mode 100644 index 0000000..958c604 --- /dev/null +++ b/t/03-tee.t @@ -0,0 +1,36 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/next_fd/; +use Cases qw/run_test/; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; +if ( $no_fork ) { + plan skip_all => 'tee() requires fork'; +} +else { + plan 'no_plan'; +} + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; + +my $fd = next_fd; + +run_test('tee'); +run_test('tee_scalar'); +run_test('tee_stdout'); +run_test('tee_stderr'); +run_test('tee_merged'); + +is( next_fd, $fd, "no file descriptors leaked" ); + +exit 0; diff --git a/t/06-stdout-closed.t b/t/06-stdout-closed.t new file mode 100644 index 0000000..5b98e56 --- /dev/null +++ b/t/06-stdout-closed.t @@ -0,0 +1,49 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/save_std restore_std next_fd/; +use Cases qw/run_test/; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; + +plan 'no_plan'; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; + +save_std(qw/stdout/); +ok( close STDOUT, "closed STDOUT" ); + +my $fd = next_fd; + +run_test($_) for qw( + capture + capture_scalar + capture_stdout + capture_stderr + capture_merged +); + +if ( ! $no_fork ) { + run_test($_) for qw( + tee + tee_scalar + tee_stdout + tee_stderr + tee_merged + ); +} + +is( next_fd, $fd, "no file descriptors leaked" ); +restore_std(qw/stdout/); + +exit 0; + diff --git a/t/07-stderr-closed.t b/t/07-stderr-closed.t new file mode 100644 index 0000000..1d814a3 --- /dev/null +++ b/t/07-stderr-closed.t @@ -0,0 +1,48 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/save_std restore_std next_fd/; +use Cases qw/run_test/; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; + +plan 'no_plan'; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; + +save_std(qw/stderr/); +ok( close STDERR, "closed STDERR" ); + +my $fd = next_fd; + +run_test($_) for qw( + capture + capture_scalar + capture_stdout + capture_stderr + capture_merged +); + +if ( ! $no_fork ) { + run_test($_) for qw( + tee + tee_scalar + tee_stdout + tee_stderr + tee_merged + ); +} + +is( next_fd, $fd, "no file descriptors leaked" ); +restore_std(qw/stderr/); + +exit 0; diff --git a/t/08-stdin-closed.t b/t/08-stdin-closed.t new file mode 100644 index 0000000..af3618f --- /dev/null +++ b/t/08-stdin-closed.t @@ -0,0 +1,65 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/save_std restore_std next_fd/; +use Cases qw/run_test/; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; + +plan 'no_plan'; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; + +# XXX work around a bug in perl; this needs to be called early-ish +# to avoid some sort of filehandle leak when combined with Capture::Tiny +my $qm = quotemeta("\x{263a}"); + +save_std(qw/stdin/); +ok( close STDIN, "closed STDIN" ); + +my $fd = next_fd; + +run_test($_) for qw( + capture + capture_scalar + capture_stdout + capture_stderr + capture_merged +); + +if ( ! $no_fork ) { + # prior to 5.12, PERL_UNICODE=D causes problems when STDIN is closed + # before capturing. No idea why. Documented as a known issue. + if ( $] lt '5.012' && ${^UNICODE} & 24 ) { + diag 'Skipping tee() tests because PERL_UNICODE=D not supported'; + } + else { + run_test($_) for qw( + tee + tee_scalar + tee_stdout + tee_stderr + tee_merged + ); + } +} + +if ( $] lt '5.012' && ${^UNICODE} & 24 ) { + diag 'Skipping leak test because PERL_UNICODE=D not supported'; +} +else { + is( next_fd, $fd, "no file descriptors leaked" ); +} + +restore_std(qw/stdin/); + +exit 0; diff --git a/t/09-preserve-exit-code.t b/t/09-preserve-exit-code.t new file mode 100644 index 0000000..8679d73 --- /dev/null +++ b/t/09-preserve-exit-code.t @@ -0,0 +1,30 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/next_fd sig_num/; +use Capture::Tiny qw/capture/; +use Config; + +plan tests => 2; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; + +my $fd = next_fd; + +capture { + $? = 42; +}; +is( $?, 42, "\$\? preserved after capture ends" ); + +is( next_fd, $fd, "no file descriptors leaked" ); + +exit 0; + diff --git a/t/10-stdout-string.t b/t/10-stdout-string.t new file mode 100644 index 0000000..93f9d80 --- /dev/null +++ b/t/10-stdout-string.t @@ -0,0 +1,53 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/save_std restore_std next_fd/; +use Cases qw/run_test/; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; + +plan skip_all => "In memory files require Perl 5.8" + if $] < 5.008; + +plan 'no_plan'; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; + +save_std(qw/stdout/); +ok( close STDOUT, "closed STDOUT" ); +ok( open( STDOUT, ">", \(my $stdout_buf)), "reopened STDOUT to string" ); + +my $fd = next_fd; + +run_test($_) for qw( + capture + capture_scalar + capture_stdout + capture_stderr + capture_merged +); + +if ( ! $no_fork ) { + run_test($_) for qw( + tee + tee_scalar + tee_stdout + tee_stderr + tee_merged + ); +} + +is( next_fd, $fd, "no file descriptors leaked" ); +restore_std(qw/stdout/); + +exit 0; + diff --git a/t/11-stderr-string.t b/t/11-stderr-string.t new file mode 100644 index 0000000..916d43d --- /dev/null +++ b/t/11-stderr-string.t @@ -0,0 +1,52 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/save_std restore_std next_fd/; +use Cases qw/run_test/; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; + +plan skip_all => "In memory files require Perl 5.8" + if $] < 5.008; + +plan 'no_plan'; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; + +save_std(qw/stderr/); +ok( close STDERR, "closed STDERR" ); +ok( open( STDERR, ">", \(my $stderr_buf)), "reopened STDERR to string" ); + +my $fd = next_fd; + +run_test($_) for qw( + capture + capture_scalar + capture_stdout + capture_stderr + capture_merged +); + +if ( ! $no_fork ) { + run_test($_) for qw( + tee + tee_scalar + tee_stdout + tee_stderr + tee_merged + ); +} + +is( next_fd, $fd, "no file descriptors leaked" ); +restore_std(qw/stderr/); + +exit 0; diff --git a/t/12-stdin-string.t b/t/12-stdin-string.t new file mode 100644 index 0000000..59fdca0 --- /dev/null +++ b/t/12-stdin-string.t @@ -0,0 +1,59 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/save_std restore_std next_fd/; +use Cases qw/run_test/; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; + +plan skip_all => "In memory files require Perl 5.8" + if $] < 5.008; + +plan 'no_plan'; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; + +#--------------------------------------------------------------------------# + +# pre-load PerlIO::scalar to avoid it opening on FD 0; c.f. +# http://www.nntp.perl.org/group/perl.perl5.porters/2008/07/msg138898.html +require PerlIO::scalar; + +save_std(qw/stdin/); +ok( close STDIN, "closed STDIN" ); +ok( open( STDIN, "<", \(my $stdin_buf)), "reopened STDIN to string" ); + +my $fd = next_fd; + +run_test($_) for qw( + capture + capture_scalar + capture_stdout + capture_stderr + capture_merged +); + +if ( ! $no_fork ) { + run_test($_) for qw( + tee + tee_scalar + tee_stdout + tee_stderr + tee_merged + ); +} + +is( next_fd, $fd, "no file descriptors leaked" ); +restore_std(qw/stdin/); + +exit 0; + diff --git a/t/13-stdout-tied.t b/t/13-stdout-tied.t new file mode 100644 index 0000000..b52f2f6 --- /dev/null +++ b/t/13-stdout-tied.t @@ -0,0 +1,56 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/save_std restore_std next_fd/; +use Cases qw/run_test/; +use TieLC; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; + +plan skip_all => "capture needs Perl 5.8 for tied STDOUT" + if $] < 5.008; + +plan 'no_plan'; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; +binmode($builder->todo_output, ':utf8') if $] >= 5.008; + +save_std(qw/stdout/); +tie *STDOUT, 'TieLC', ">&=STDOUT"; +my $orig_tie = tied *STDOUT; +ok( $orig_tie, "STDOUT is tied" ); + +my $fd = next_fd; + +run_test($_) for qw( + capture + capture_scalar + capture_stdout + capture_stderr + capture_merged +); + +if ( ! $no_fork ) { + run_test($_) for qw( + tee + tee_scalar + tee_stdout + tee_stderr + tee_merged + ); +} + +is( next_fd, $fd, "no file descriptors leaked" ); +is( tied *STDOUT, $orig_tie, "STDOUT is still tied" ); +restore_std(qw/stdout/); + +exit 0; diff --git a/t/14-stderr-tied.t b/t/14-stderr-tied.t new file mode 100644 index 0000000..567bc0b --- /dev/null +++ b/t/14-stderr-tied.t @@ -0,0 +1,56 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/save_std restore_std next_fd/; +use Cases qw/run_test/; +use TieLC; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; + +plan skip_all => "capture needs Perl 5.8 for tied STDERR" + if $] < 5.008; + +plan 'no_plan'; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; +binmode($builder->todo_output, ':utf8') if $] >= 5.008; + +save_std(qw/stderr/); +tie *STDERR, 'TieLC', ">&=STDERR"; +my $orig_tie = tied *STDERR; +ok( $orig_tie, "STDERR is tied" ); + +my $fd = next_fd; + +run_test($_) for qw( + capture + capture_scalar + capture_stdout + capture_stderr + capture_merged +); + +if ( ! $no_fork ) { + run_test($_) for qw( + tee + tee_scalar + tee_stdout + tee_stderr + tee_merged + ); +} + +is( next_fd, $fd, "no file descriptors leaked" ); +is( tied *STDERR, $orig_tie, "STDERR is still tied" ); +restore_std(qw/stderr/); + +exit 0; diff --git a/t/15-stdin-tied.t b/t/15-stdin-tied.t new file mode 100644 index 0000000..4852c2b --- /dev/null +++ b/t/15-stdin-tied.t @@ -0,0 +1,58 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/save_std restore_std next_fd/; +use Cases qw/run_test/; +use TieLC; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; + +plan skip_all => "capture needs Perl 5.8 for tied STDERR" + if $] < 5.008; + +#plan skip_all => "not supported on Windows yet" +# if $^O eq 'MSWin32'; + +plan 'no_plan'; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; + +save_std(qw/stdin/); +tie *STDIN, 'TieLC', "<&=STDIN"; +my $orig_tie = tied *STDIN; +ok( $orig_tie, "STDIN is tied" ); + +my $fd = next_fd; + +run_test($_) for qw( + capture + capture_scalar + capture_stdout + capture_stderr + capture_merged +); + +if ( ! $no_fork ) { + run_test($_) for qw( + tee + tee_scalar + tee_stdout + tee_stderr + tee_merged + ); +} + +is( next_fd, $fd, "no file descriptors leaked" ); +is( tied *STDIN, $orig_tie, "STDIN is still tied" ); +restore_std(qw/stdin/); + +exit 0; diff --git a/t/16-catch-errors.t b/t/16-catch-errors.t new file mode 100644 index 0000000..bea7550 --- /dev/null +++ b/t/16-catch-errors.t @@ -0,0 +1,47 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/next_fd sig_num/; +use Capture::Tiny qw/capture tee/; +use Config; + +plan tests => 5; + +local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # no timeouts + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; + +my $fd = next_fd; +$@ = "initial error"; +my ($out, $err) = capture { print "foo\n" }; +is( $@, 'initial error', "Initial \$\@ not lost during capture" ); + + +($out, $err) = capture { + eval { + tee { + local $|=1; + print STDOUT "foo\n"; + print STDERR "bar\n"; + die "Fatal error in capture\n"; + } + }; +}; +my $error = $@; + +is( $error, "Fatal error in capture\n", "\$\@ preserved after capture" ); +is( $out, "foo\n", "STDOUT still captured" ); +is( $err, "bar\n", "STDOUT still captured" ); + +is( next_fd, $fd, "no file descriptors leaked" ); + +exit 0; + diff --git a/t/17-pass-results.t b/t/17-pass-results.t new file mode 100644 index 0000000..320259d --- /dev/null +++ b/t/17-pass-results.t @@ -0,0 +1,87 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use IO::Handle; +use Utils qw/next_fd sig_num/; +use Capture::Tiny ':all'; +use Config; + +plan tests => 12; + +local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # no timeouts + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; + +my $fd = next_fd; +my ($out, $err, $res, @res); + +#--------------------------------------------------------------------------# +# capture to array +#--------------------------------------------------------------------------# + +($out, $err, @res) = capture { + print STDOUT "foo\n"; + print STDERR "bar\n"; + return qw/one two three/; +}; + +is( $out, "foo\n", "capture -> STDOUT captured" ); +is( $err, "bar\n", "capture -> STDERR captured" ); +is_deeply( \@res, [qw/one two three/], "return values -> array" ); + +#--------------------------------------------------------------------------# +# capture to scalar +#--------------------------------------------------------------------------# + +($out, $err, $res) = capture { + print STDOUT "baz\n"; + print STDERR "bam\n"; + return qw/one two three/; +}; + +is( $out, "baz\n", "capture -> STDOUT captured" ); +is( $err, "bam\n", "capture -> STDERR captured" ); +is( $res, "one", "return value -> scalar" ); + +#--------------------------------------------------------------------------# +# capture_stdout to array +#--------------------------------------------------------------------------# + +($out, @res) = capture_stdout { + print STDOUT "foo\n"; + return qw/one two three/; +}; + +is( $out, "foo\n", "capture_stdout -> STDOUT captured" ); +is_deeply( \@res, [qw/one two three/], "return values -> array" ); + +#--------------------------------------------------------------------------# +# capture_merged to array +#--------------------------------------------------------------------------# + +($out, $res) = capture_merged { + print STDOUT "baz\n"; + print STDERR "bam\n"; + return qw/one two three/; +}; + +like( $out, qr/baz/, "capture_merged -> STDOUT captured" ); +like( $out, qr/bam/, "capture_merged -> STDERR captured" ); +is( $res, "one", "return value -> scalar" ); + +#--------------------------------------------------------------------------# +# finish +#--------------------------------------------------------------------------# + +is( next_fd, $fd, "no file descriptors leaked" ); + +exit 0; + diff --git a/t/18-custom-capture.t b/t/18-custom-capture.t new file mode 100644 index 0000000..8af8b28 --- /dev/null +++ b/t/18-custom-capture.t @@ -0,0 +1,169 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use IO::Handle; +use IO::File; +use File::Temp qw/tmpnam/; +use Utils qw/next_fd sig_num/; +use Capture::Tiny ':all'; +use Config; + +plan tests => 19; + +local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # no timeouts + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; + +my $fd = next_fd; +my ($out, $err, $res, @res); + +#--------------------------------------------------------------------------# +# capture to custom IO::File +#--------------------------------------------------------------------------# + +my $temp_out = tmpnam(); +my $temp_err = tmpnam(); + +ok( !-e $temp_out, "Temp out '$temp_out' doesn't exist" ); +ok( !-e $temp_err, "Temp out '$temp_err' doesn't exist" ); + +my $out_fh = IO::File->new($temp_out, "w+"); +my $err_fh = IO::File->new($temp_err, "w+"); + +capture { + print STDOUT "foo\n"; + print STDERR "bar\n"; +} stdout => $out_fh, stderr => $err_fh; + +$out_fh->close; +$err_fh->close; + +is( scalar do {local (@ARGV,$/) = $temp_out; <>} , "foo\n", + "captured STDOUT to custom handle (IO::File)" +); +is( scalar do {local (@ARGV,$/) = $temp_err; <>} , "bar\n", + "captured STDERR to custom handle (IO::File)" +); + +unlink $_ for $temp_out, $temp_err; + +#--------------------------------------------------------------------------# +# capture to GLOB handle +#--------------------------------------------------------------------------# + +$temp_out = tmpnam(); +$temp_err = tmpnam(); + +ok( !-e $temp_out, "Temp out '$temp_out' doesn't exist" ); +ok( !-e $temp_err, "Temp out '$temp_err' doesn't exist" ); + +open $out_fh, "+>", $temp_out; +open $err_fh, "+>", $temp_err; + +capture { + print STDOUT "foo\n"; + print STDERR "bar\n"; +} stdout => $out_fh, stderr => $err_fh; + +$out_fh->close; +$err_fh->close; + +is( scalar do {local (@ARGV,$/) = $temp_out; <>} , "foo\n", + "captured STDOUT to custom handle (GLOB)" +); +is( scalar do {local (@ARGV,$/) = $temp_err; <>} , "bar\n", + "captured STDERR to custom handle (GLOB)" +); + +unlink $_ for $temp_out, $temp_err; + +#--------------------------------------------------------------------------# +# append to custom IO::File +#--------------------------------------------------------------------------# + +$temp_out = tmpnam(); +$temp_err = tmpnam(); + +ok( !-e $temp_out, "Temp out '$temp_out' doesn't exist" ); +ok( !-e $temp_err, "Temp out '$temp_err' doesn't exist" ); + +$out_fh = IO::File->new($temp_out, "w+"); +$err_fh = IO::File->new($temp_err, "w+"); + +$out_fh->autoflush(1); +$err_fh->autoflush(1); + +print $out_fh "Shouldn't see this in capture\n"; +print $err_fh "Shouldn't see this in capture\n"; + +my ($got_out, $got_err) = capture { + print STDOUT "foo\n"; + print STDERR "bar\n"; +} stdout => $out_fh, stderr => $err_fh; + +$out_fh->close; +$err_fh->close; + +is( $got_out, "foo\n", + "captured appended STDOUT to custom handle" +); +is( $got_err, "bar\n", + "captured appended STDERR to custom handle" +); + +unlink $_ for $temp_out, $temp_err; + +#--------------------------------------------------------------------------# +# repeated append to custom IO::File with no output +#--------------------------------------------------------------------------# + +$temp_out = tmpnam(); +$temp_err = tmpnam(); + +ok( !-e $temp_out, "Temp out '$temp_out' doesn't exist" ); +ok( !-e $temp_err, "Temp out '$temp_err' doesn't exist" ); + +$out_fh = IO::File->new($temp_out, "a+"); +$err_fh = IO::File->new($temp_err, "a+"); + +($got_out, $got_err) = capture { + my $i = 0; $i++ for 1 .. 10; # no output, just busywork +} stdout => $out_fh, stderr => $err_fh; + +is( $got_out, "", + "Try 1: captured empty appended STDOUT to custom handle" +); +is( $got_err, "", + "Try 1: captured empty appended STDERR to custom handle" +); + +($got_out, $got_err) = capture { + my $i = 0; $i++ for 1 .. 10; # no output, just busywork +} stdout => $out_fh, stderr => $err_fh; + +is( $got_out, "", + "Try 2: captured empty appended STDOUT to custom handle" +); +is( $got_err, "", + "Try 2: captured empty appended STDERR to custom handle" +); + +unlink $_ for $temp_out, $temp_err; + +#--------------------------------------------------------------------------# +# finish +#--------------------------------------------------------------------------# + +close ARGV; # opened by reading from <> +is( next_fd, $fd, "no file descriptors leaked" ); + +exit 0; + diff --git a/t/19-relayering.t b/t/19-relayering.t new file mode 100644 index 0000000..9911c74 --- /dev/null +++ b/t/19-relayering.t @@ -0,0 +1,83 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/next_fd sig_num/; +use Capture::Tiny ':all'; + +unless ( PerlIO->can('get_layers') ) { + plan skip_all => "Requires PerlIO::getlayers"; +} + +plan 'no_plan'; + +local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # no timeouts + +my $builder = Test::More->builder; +binmode( $builder->failure_output, ':utf8' ) if $] >= 5.008; + +my $fd = next_fd; +my ( $out, $err, $res, @res, %before, %inner, %outer ); + +sub _set_layers { + my ($fh, $new_layers) = @_; + # eliminate pseudo-layers + binmode( $fh, ":raw" ) or die "can't binmode $fh"; + # strip off real layers until only :unix is left + while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) { + binmode( $fh, ":pop" ) or die "can't binmode $fh"; + } + binmode($fh, $new_layers); +} + +sub _get_layers { + return ( + stdout => [ PerlIO::get_layers( *STDOUT, output => 1 ) ], + stderr => [ PerlIO::get_layers( *STDERR, output => 1 ) ], + ); +} + +sub _cmp_layers { + local $Test::Builder::Level = $Test::Builder::Level + 1; + my ($got, $exp, $label) = @_; + + ($got, $exp) = map { ":" . join(":", @$_) } $got, $exp; + is( $got, $exp, $label ); +} + +#--------------------------------------------------------------------------# +# relayer should duplicate layers +#--------------------------------------------------------------------------# + +_set_layers( \*STDOUT, ":unix:encoding(UTF-8):encoding(UTF-8):crlf" ); +_set_layers( \*STDERR, ":unix:encoding(UTF-8):encoding(UTF-8):crlf" ); + +%before = _get_layers(); + +( $out, $err, @res ) = capture { + %inner = _get_layers(); + print STDOUT "foo\n"; + print STDERR "bar\n"; +}; + +%outer = _get_layers(); + +_cmp_layers( $inner{$_}, $before{$_}, "$_: layers inside capture match previous" ) + for qw/stdout stderr/; +_cmp_layers( $outer{$_}, $before{$_}, "$_: layers after capture match previous" ) + for qw/stdout stderr/; + +#--------------------------------------------------------------------------# +# finish +#--------------------------------------------------------------------------# + +is( next_fd, $fd, "no file descriptors leaked" ); + +exit 0; +# vim: set ts=4 sts=4 sw=4 et tw=75: diff --git a/t/20-stdout-badtie.t b/t/20-stdout-badtie.t new file mode 100644 index 0000000..0305c5d --- /dev/null +++ b/t/20-stdout-badtie.t @@ -0,0 +1,54 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/save_std restore_std next_fd/; +use Cases qw/run_test/; +use TieEvil; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; + +plan skip_all => "capture needs Perl 5.8 for tied STDOUT" + if $] < 5.008; + +plan 'no_plan'; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; +binmode($builder->todo_output, ':utf8') if $] >= 5.008; + +tie *STDOUT, 'TieEvil'; +my $orig_tie = tied *STDOUT; +ok( $orig_tie, "STDOUT is tied" ); + +my $fd = next_fd; + +run_test($_, '', 'skip_utf8') for qw( + capture + capture_scalar + capture_stdout + capture_stderr + capture_merged +); + +if ( ! $no_fork ) { + run_test($_, '', 'skip_utf8') for qw( + tee + tee_scalar + tee_stdout + tee_stderr + tee_merged + ); +} + +is( next_fd, $fd, "no file descriptors leaked" ); +is( tied *STDOUT, $orig_tie, "STDOUT is still tied" ); + +exit 0; diff --git a/t/21-stderr-badtie.t b/t/21-stderr-badtie.t new file mode 100644 index 0000000..8bcefb8 --- /dev/null +++ b/t/21-stderr-badtie.t @@ -0,0 +1,54 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/save_std restore_std next_fd/; +use Cases qw/run_test/; +use TieEvil; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; + +plan skip_all => "capture needs Perl 5.8 for tied STDERR" + if $] < 5.008; + +plan 'no_plan'; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; +binmode($builder->todo_output, ':utf8') if $] >= 5.008; + +tie *STDERR, 'TieEvil'; +my $orig_tie = tied *STDERR; +ok( $orig_tie, "STDERR is tied" ); + +my $fd = next_fd; + +run_test($_, '', 'skip_utf8') for qw( + capture + capture_scalar + capture_stdout + capture_stderr + capture_merged +); + +if ( ! $no_fork ) { + run_test($_, '', 'skip_utf8') for qw( + tee + tee_scalar + tee_stdout + tee_stderr + tee_merged + ); +} + +is( next_fd, $fd, "no file descriptors leaked" ); +is( tied *STDERR, $orig_tie, "STDERR is still tied" ); + +exit 0; diff --git a/t/22-stdin-badtie.t b/t/22-stdin-badtie.t new file mode 100644 index 0000000..f67d40b --- /dev/null +++ b/t/22-stdin-badtie.t @@ -0,0 +1,54 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/save_std restore_std next_fd/; +use Cases qw/run_test/; +use TieEvil; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; + +plan skip_all => "capture needs Perl 5.8 for tied STDIN" + if $] < 5.008; + +plan 'no_plan'; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; +binmode($builder->todo_output, ':utf8') if $] >= 5.008; + +tie *STDIN, 'TieEvil'; +my $orig_tie = tied *STDIN; +ok( $orig_tie, "STDIN is tied" ); + +my $fd = next_fd; + +run_test($_, '', 'skip_utf8') for qw( + capture + capture_scalar + capture_stdout + capture_stderr + capture_merged +); + +if ( ! $no_fork ) { + run_test($_, '', 'skip_utf8') for qw( + tee + tee_scalar + tee_stdout + tee_stderr + tee_merged + ); +} + +is( next_fd, $fd, "no file descriptors leaked" ); +is( tied *STDIN, $orig_tie, "STDIN is still tied" ); + +exit 0; diff --git a/t/23-all-tied.t b/t/23-all-tied.t new file mode 100644 index 0000000..9e88e47 --- /dev/null +++ b/t/23-all-tied.t @@ -0,0 +1,64 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/save_std restore_std next_fd/; +use Cases qw/run_test/; +use TieLC; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; + +plan skip_all => "capture needs Perl 5.8 for tied STDOUT" + if $] < 5.008; + +plan 'no_plan'; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; +binmode($builder->todo_output, ':utf8') if $] >= 5.008; + +save_std(qw/stdout stderr stdin/); +tie *STDOUT, 'TieLC', ">&=STDOUT"; +my $out_tie = tied *STDOUT; +ok( $out_tie, "STDOUT is tied" ); +tie *STDERR, 'TieLC', ">&=STDERR"; +my $err_tie = tied *STDERR; +ok( $err_tie, "STDERR is tied" ); +tie *STDIN, 'TieLC', "<&=STDIN"; +my $in_tie = tied *STDIN; +ok( $in_tie, "STDIN is tied" ); + +my $fd = next_fd; + +run_test($_) for qw( + capture + capture_scalar + capture_stdout + capture_stderr + capture_merged +); + +if ( ! $no_fork ) { + run_test($_) for qw( + tee + tee_scalar + tee_stdout + tee_stderr + tee_merged + ); +} + +is( next_fd, $fd, "no file descriptors leaked" ); +is( tied *STDOUT, $out_tie, "STDOUT is still tied" ); +is( tied *STDERR, $err_tie, "STDERR is still tied" ); +is( tied *STDIN, $in_tie, "STDIN is still tied" ); +restore_std(qw/stdout stderr stdin/); + +exit 0; diff --git a/t/24-all-badtied.t b/t/24-all-badtied.t new file mode 100644 index 0000000..846d811 --- /dev/null +++ b/t/24-all-badtied.t @@ -0,0 +1,64 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/save_std restore_std next_fd/; +use Cases qw/run_test/; +use TieEvil; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; + +plan skip_all => "capture needs Perl 5.8 for tied STDIN" + if $] < 5.008; + +plan 'no_plan'; + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; +binmode($builder->todo_output, ':utf8') if $] >= 5.008; + +tie *STDIN, 'TieEvil'; +my $in_tie = tied *STDIN; +ok( $in_tie, "STDIN is tied" ); + +tie *STDOUT, 'TieEvil'; +my $out_tie = tied *STDOUT; +ok( $out_tie, "STDIN is tied" ); + +tie *STDERR, 'TieEvil'; +my $err_tie = tied *STDERR; +ok( $err_tie, "STDIN is tied" ); + +my $fd = next_fd; + +run_test($_, '', 'skip_utf8') for qw( + capture + capture_scalar + capture_stdout + capture_stderr + capture_merged +); + +if ( ! $no_fork ) { + run_test($_, '', 'skip_utf8') for qw( + tee + tee_scalar + tee_stdout + tee_stderr + tee_merged + ); +} + +is( next_fd, $fd, "no file descriptors leaked" ); +is( tied *STDIN, $in_tie, "STDIN is still tied" ); +is( tied *STDOUT, $out_tie, "STDOUT is still tied" ); +is( tied *STDERR, $err_tie, "STDERR is still tied" ); + +exit 0; diff --git a/t/25-cap-fork.t b/t/25-cap-fork.t new file mode 100644 index 0000000..c10bca0 --- /dev/null +++ b/t/25-cap-fork.t @@ -0,0 +1,50 @@ +# By Yary Hluchan with portions copied from David Golden +# Copyright (c) 2015 assigned by Yary Hluchan to David Golden. +# All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use Utils qw/next_fd/; +use Capture::Tiny 'capture'; + +use Config; +my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; +if ( $no_fork ) { + plan skip_all => 'tee() requires fork'; +} +else { + plan 'no_plan'; +} + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; + +my $fd = next_fd; + + +my ($stdout, $stderr, @result) = capture { + if (!defined(my $child = fork)) { die "fork() failed" } + elsif ($child == 0) { + print "Happiness"; + print STDERR "Certainty\n"; + exit; + } + else { + wait; + print ", a parent-ly\n"; + } + return qw(a b c); +}; + +is ( $stdout, "Happiness, a parent-ly\n", "got stdout"); +is ( $stderr, "Certainty\n", "got stderr"); +is ( "@result", "a b c" , "got result"); +is ( next_fd, $fd, "no file descriptors leaked" ); + +exit 0; diff --git a/t/lib/Cases.pm b/t/lib/Cases.pm new file mode 100644 index 0000000..4be0a31 --- /dev/null +++ b/t/lib/Cases.pm @@ -0,0 +1,286 @@ +package Cases; +use strict; +use warnings; +use Test::More; +use Capture::Tiny ':all'; + +require Exporter; +our @ISA = 'Exporter'; +our @EXPORT_OK = qw( + run_test +); + +my $locale_ok = eval { + my $err = capture_stderr { system($^X, '-we', 1) }; + $err !~ /setting locale failed/i; +}; + +my $have_diff = eval { + require Test::Differences; + Test::Differences->import; + $Test::Differences::VERSION < 0.60; # 0.60+ is causing strange failures +}; + +sub _is_or_diff { + my ($g,$e,$l) = @_; + if ( $have_diff ) { eq_or_diff( $g, $e, $l ); } + else { is( $g, $e, $l ); } +} + +sub _binmode { + my $text = shift; + return $text eq 'unicode' ? 'binmode(STDOUT,q{:utf8}); binmode(STDERR,q{:utf8});' : ''; +} + +sub _set_utf8 { + my $t = shift; + return unless $t eq 'unicode'; + my %seen; + my @orig_layers = ( + [ grep {$_ ne 'unix' and $_ ne 'perlio' and $seen{stdout}{$_}++} PerlIO::get_layers(\*STDOUT) ], + [ grep {$_ ne 'unix' and $_ ne 'perlio' and $seen{stderr}{$_}++} PerlIO::get_layers(\*STDERR) ], + ); + binmode(STDOUT, ":utf8") if fileno(STDOUT); + binmode(STDERR, ":utf8") if fileno(STDERR); + return @orig_layers; +} + +sub _restore_layers { + my ($t, @orig_layers) = @_; + return unless $t eq 'unicode'; + binmode(STDOUT, join( ":", "", "raw", @{$orig_layers[0]})) if fileno(STDOUT); + binmode(STDERR, join( ":", "", "raw", @{$orig_layers[1]})) if fileno(STDERR); +} + +#--------------------------------------------------------------------------# + +my %texts = ( + short => 'Hello World', + multiline => 'First line\nSecond line\n', + ( $] lt "5.008" ? () : ( unicode => 'Hi! \x{263a}\n') ), +); + +#--------------------------------------------------------------------------# +# fcn($perl_code_string) => execute the perl in current process or subprocess +#--------------------------------------------------------------------------# + +my %methods = ( + perl => sub { eval $_[0] }, + sys => sub { system($^X, '-e', $_[0]) }, +); + +#--------------------------------------------------------------------------# + +my %channels = ( + stdout => { + output => sub { _binmode($_[0]) . "print STDOUT qq{STDOUT:$texts{$_[0]}}" }, + expect => sub { eval "qq{STDOUT:$texts{$_[0]}}", "" }, + }, + stderr => { + output => sub { _binmode($_[0]) . "print STDERR qq{STDERR:$texts{$_[0]}}" }, + expect => sub { "", eval "qq{STDERR:$texts{$_[0]}}" }, + }, + both => { + output => sub { _binmode($_[0]) . "print STDOUT qq{STDOUT:$texts{$_[0]}}; print STDERR qq{STDERR:$texts{$_[0]}}" }, + expect => sub { eval "qq{STDOUT:$texts{$_[0]}}", eval "qq{STDERR:$texts{$_[0]}}" }, + }, + empty => { + output => sub { _binmode($_[0]) . "print STDOUT qq{}; print STDERR qq{}" }, + expect => sub { "", "" }, + }, + nooutput=> { + output => sub { _binmode($_[0]) }, + expect => sub { "", "" }, + }, +); + +#--------------------------------------------------------------------------# + +my %tests = ( + capture => { + cnt => 2, + test => sub { + my ($m, $c, $t, $l) = @_; + my ($got_out, $got_err) = capture { + $methods{$m}->( $channels{$c}{output}->($t) ); + }; + my @expected = $channels{$c}{expect}->($t); + _is_or_diff( $got_out, $expected[0], "$l|$m|$c|$t - got STDOUT" ); + _is_or_diff( $got_err, $expected[1], "$l|$m|$c|$t - got STDERR" ); + }, + }, + capture_scalar => { + cnt => 1, + test => sub { + my ($m, $c, $t, $l) = @_; + my $got_out = capture { + $methods{$m}->( $channels{$c}{output}->($t) ); + }; + my @expected = $channels{$c}{expect}->($t); + _is_or_diff( $got_out, $expected[0], "$l|$m|$c|$t - got STDOUT" ); + }, + }, + capture_stdout => { + cnt => 3, + test => sub { + my ($m, $c, $t, $l) = @_; + my ($inner_out, $inner_err); + my ($outer_out, $outer_err) = capture { + $inner_out = capture_stdout { + $methods{$m}->( $channels{$c}{output}->($t) ); + }; + }; + my @expected = $channels{$c}{expect}->($t); + _is_or_diff( $inner_out, $expected[0], "$l|$m|$c|$t - inner STDOUT" ); + _is_or_diff( $outer_out, "", "$l|$m|$c|$t - outer STDOUT" ); + _is_or_diff( $outer_err, $expected[1], "$l|$m|$c|$t - outer STDERR" ); + }, + }, + capture_stderr => { + cnt => 3, + test => sub { + my ($m, $c, $t, $l) = @_; + my ($inner_out, $inner_err); + my ($outer_out, $outer_err) = capture { + $inner_err = capture_stderr { + $methods{$m}->( $channels{$c}{output}->($t) ); + }; + }; + my @expected = $channels{$c}{expect}->($t); + _is_or_diff( $inner_err, $expected[1], "$l|$m|$c|$t - inner STDERR" ); + _is_or_diff( $outer_out, $expected[0], "$l|$m|$c|$t - outer STDOUT" ); + _is_or_diff( $outer_err, "", "$l|$m|$c|$t - outer STDERR" ); + }, + }, + capture_merged => { + cnt => 2, + test => sub { + my ($m, $c, $t, $l) = @_; + my $got_out = capture_merged { + $methods{$m}->( $channels{$c}{output}->($t) ); + }; + my @expected = $channels{$c}{expect}->($t); + like( $got_out, qr/\Q$expected[0]\E/, "$l|$m|$c|$t - got STDOUT" ); + like( $got_out, qr/\Q$expected[1]\E/, "$l|$m|$c|$t - got STDERR" ); + }, + }, + tee => { + cnt => 4, + test => sub { + my ($m, $c, $t, $l) = @_; + my ($got_out, $got_err); + my ($tee_out, $tee_err) = capture { + ($got_out, $got_err) = tee { + $methods{$m}->( $channels{$c}{output}->($t) ); + }; + }; + my @expected = $channels{$c}{expect}->($t); + _is_or_diff( $got_out, $expected[0], "$l|$m|$c|$t - got STDOUT" ); + _is_or_diff( $tee_out, $expected[0], "$l|$m|$c|$t - tee STDOUT" ); + _is_or_diff( $got_err, $expected[1], "$l|$m|$c|$t - got STDERR" ); + _is_or_diff( $tee_err, $expected[1], "$l|$m|$c|$t - tee STDERR" ); + } + }, + tee_scalar => { + cnt => 3, + test => sub { + my ($m, $c, $t, $l) = @_; + my ($got_out, $got_err); + my ($tee_out, $tee_err) = capture { + $got_out = tee { + $methods{$m}->( $channels{$c}{output}->($t) ); + }; + }; + my @expected = $channels{$c}{expect}->($t); + _is_or_diff( $got_out, $expected[0], "$l|$m|$c|$t - got STDOUT" ); + _is_or_diff( $tee_out, $expected[0], "$l|$m|$c|$t - tee STDOUT" ); + _is_or_diff( $tee_err, $expected[1], "$l|$m|$c|$t - tee STDERR" ); + } + }, + tee_stdout => { + cnt => 3, + test => sub { + my ($m, $c, $t, $l) = @_; + my ($inner_out, $inner_err); + my ($tee_out, $tee_err) = capture { + $inner_out = tee_stdout { + $methods{$m}->( $channels{$c}{output}->($t) ); + }; + }; + my @expected = $channels{$c}{expect}->($t); + _is_or_diff( $inner_out, $expected[0], "$l|$m|$c|$t - inner STDOUT" ); + _is_or_diff( $tee_out, $expected[0], "$l|$m|$c|$t - teed STDOUT" ); + _is_or_diff( $tee_err, $expected[1], "$l|$m|$c|$t - unmodified STDERR" ); + } + }, + tee_stderr => { + cnt => 3, + test => sub { + my ($m, $c, $t, $l) = @_; + my ($inner_out, $inner_err); + my ($tee_out, $tee_err) = capture { + $inner_err = tee_stderr { + $methods{$m}->( $channels{$c}{output}->($t) ); + }; + }; + my @expected = $channels{$c}{expect}->($t); + _is_or_diff( $inner_err, $expected[1], "$l|$m|$c|$t - inner STDOUT" ); + _is_or_diff( $tee_out, $expected[0], "$l|$m|$c|$t - unmodified STDOUT" ); + _is_or_diff( $tee_err, $expected[1], "$l|$m|$c|$t - teed STDERR" ); + } + }, + tee_merged => { + cnt => 5, + test => sub { + my ($m, $c, $t, $l) = @_; + my ($got_out, $got_err); + my ($tee_out, $tee_err) = capture { + $got_out = tee_merged { + $methods{$m}->( $channels{$c}{output}->($t) ); + }; + }; + my @expected = $channels{$c}{expect}->($t); + like( $got_out, qr/\Q$expected[0]\E/, "$l|$m|$c|$t - got STDOUT" ); + like( $got_out, qr/\Q$expected[1]\E/, "$l|$m|$c|$t - got STDERR" ); + like( $tee_out, qr/\Q$expected[0]\E/, "$l|$m|$c|$t - tee STDOUT (STDOUT)" ); + like( $tee_out, qr/\Q$expected[1]\E/, "$l|$m|$c|$t - tee STDOUT (STDERR)" ); + _is_or_diff( $tee_err, '', "$l|$m|$c|$t - tee STDERR" ); + } + }, +); + +#--------------------------------------------------------------------------# +# What I want to be able to do: +# +# test_it( +# input => 'short', +# channels => 'both', +# method => 'perl' +# ) + +sub run_test { + my $test_type = shift or return; + my $todo = shift || ''; + my $skip_utf8 = shift || ''; + local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # don't timeout during testing + for my $m ( keys %methods ) { + if ( ($m eq 'sys' || substr($test_type,0,3) eq 'tee' ) && ! $locale_ok ) { + SKIP: { + skip "Perl could not initialize locale", 1 + }; + next; + } + for my $c ( keys %channels ) { + for my $t ( keys %texts ) { + next if $t eq 'unicode' && $skip_utf8; + my @orig_layers = _set_utf8($t); + local $TODO = "not supported on all platforms" + if $t eq $todo; + $tests{$test_type}{test}->($m, $c, $t, $test_type); + _restore_layers($t, @orig_layers); + } + } + } +} + +1; diff --git a/t/lib/TieEvil.pm b/t/lib/TieEvil.pm new file mode 100644 index 0000000..f959dd7 --- /dev/null +++ b/t/lib/TieEvil.pm @@ -0,0 +1,35 @@ +package TieEvil; +# FCGI tied with a scalar ref object, which breaks when you +# call open on it. Emulate that to test the workaround: +use Carp (); + +sub TIEHANDLE +{ + my $class = shift; + my $fh = \(my $scalar); # this is evil and broken + return bless $fh,$class; +} + +sub EOF { 0 } +sub TELL { length ${$_[0]} } +sub FILENO { -1 } +sub SEEK { 1 } +sub CLOSE { 1 } +sub BINMODE { 1 } + +sub OPEN { Carp::confess "unimplemented" } + +sub READ { $_[1] = substr(${$_[0]},$_[3],$_[2]) } +sub READLINE { "hello world\n" } +sub GETC { substr(${$_[0]},0,1) } + +sub PRINT { + my ($self, @what) = @_; + my $new = join($\, @what); + $$self .= $new; + return length $new; +} + +sub UNTIE { 1 }; # suppress warnings about references + +1; diff --git a/t/lib/TieLC.pm b/t/lib/TieLC.pm new file mode 100644 index 0000000..1dd384e --- /dev/null +++ b/t/lib/TieLC.pm @@ -0,0 +1,44 @@ +package TieLC; + +sub TIEHANDLE +{ + my $class = shift; + my $fh = \do { local *HANDLE}; + bless $fh,$class; + $fh->OPEN(@_) if (@_); + $fh->BINMODE(':utf8'); + return $fh; +} + +sub EOF { eof($_[0]) } +sub TELL { tell($_[0]) } +sub FILENO { fileno($_[0]) } +sub SEEK { seek($_[0],$_[1],$_[2]) } +sub CLOSE { close($_[0]) } +sub BINMODE { binmode($_[0],$_[1]) } + +sub OPEN +{ + $_[0]->CLOSE if defined($_[0]->FILENO); + @_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]); +} + +sub READ { read($_[0],$_[1],$_[2]) } +sub READLINE { "hello world\n" } +sub GETC { getc($_[0]) } + +sub WRITE +{ + my $fh = $_[0]; + print $fh substr($_[1],0,$_[2]) +} + +sub PRINT { + my ($self, @what) = @_; + my $buf = lc join('', @what); + $self->WRITE($buf, length($buf), 0); +} + +sub UNTIE { 1 }; # suppress warnings about references + +1; diff --git a/t/lib/Utils.pm b/t/lib/Utils.pm new file mode 100644 index 0000000..6ea4d88 --- /dev/null +++ b/t/lib/Utils.pm @@ -0,0 +1,60 @@ +package Utils; +use strict; +use warnings; +use File::Spec; +use Config; + +require Exporter; +our @ISA = 'Exporter'; +our @EXPORT = qw/save_std restore_std next_fd sig_num/; + +sub _open { + open $_[0], $_[1] or die "Error from open( " . join(q{, }, @_) . "): $!"; +} + +my @saved; +sub save_std { + for my $h ( @_ ) { + my $fh; + _open $fh, ($h eq 'stdin' ? "<&" : ">&") . uc $h; + push @saved, $fh; + } +} + +sub restore_std { + for my $h ( @_ ) { + no strict 'refs'; + my $fh = shift @saved; + _open \*{uc $h}, ($h eq 'stdin' ? "<&" : ">&") . fileno( $fh ); + close $fh; + } +} + +sub next_fd { + no warnings 'io'; + open my $fh, ">", File::Spec->devnull; + my $fileno = fileno $fh; + close $fh; + return $fileno; +} + +#--------------------------------------------------------------------------# + +my %sig_num; +my @sig_name; +unless($Config{sig_name} && $Config{sig_num}) { + die "No sigs?"; +} else { + my @names = split ' ', $Config{sig_name}; + @sig_num{@names} = split ' ', $Config{sig_num}; + foreach (@names) { + $sig_name[$sig_num{$_}] ||= $_; + } +} + +sub sig_num { + my $name = shift; + return exists $sig_num{$name} ? $sig_num{$name} : ''; +} + +1; diff --git a/xt/author/00-compile.t b/xt/author/00-compile.t new file mode 100644 index 0000000..6404e65 --- /dev/null +++ b/xt/author/00-compile.t @@ -0,0 +1,63 @@ +use 5.006; +use strict; +use warnings; + +# this test was generated with Dist::Zilla::Plugin::Test::Compile 2.058 + +use Test::More; + +plan tests => 2; + +my @module_files = ( + 'Capture/Tiny.pm' +); + + + +# fake home for cpan-testers +use File::Temp; +local $ENV{HOME} = File::Temp::tempdir( CLEANUP => 1 ); + + +my @switches = ( + -d 'blib' ? '-Mblib' : '-Ilib', +); + +use File::Spec; +use IPC::Open3; +use IO::Handle; + +open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; + +my @warnings; +for my $lib (@module_files) +{ + # see L + my $stderr = IO::Handle->new; + + diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} } + $^X, @switches, '-e', "require q[$lib]")) + if $ENV{PERL_COMPILE_TEST_DEBUG}; + + my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-e', "require q[$lib]"); + binmode $stderr, ':crlf' if $^O eq 'MSWin32'; + my @_warnings = <$stderr>; + waitpid($pid, 0); + is($?, 0, "$lib loaded ok"); + + shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ + and not eval { +require blib; blib->VERSION('1.01') }; + + if (@_warnings) + { + warn @_warnings; + push @warnings, @_warnings; + } +} + + + +is(scalar(@warnings), 0, 'no warnings found') + or diag 'got warnings: ', ( Test::More->can('explain') ? Test::More::explain(\@warnings) : join("\n", '', @warnings) ); + + diff --git a/xt/author/critic.t b/xt/author/critic.t new file mode 100644 index 0000000..80ccdad --- /dev/null +++ b/xt/author/critic.t @@ -0,0 +1,7 @@ +#!perl + +use strict; +use warnings; + +use Test::Perl::Critic (-profile => "perlcritic.rc") x!! -e "perlcritic.rc"; +all_critic_ok(); diff --git a/xt/author/minimum-version.t b/xt/author/minimum-version.t new file mode 100644 index 0000000..d4a20c3 --- /dev/null +++ b/xt/author/minimum-version.t @@ -0,0 +1,6 @@ +#!perl + +use Test::More; + +use Test::MinimumVersion; +all_minimum_version_ok( qq{5.010} ); diff --git a/xt/author/pod-coverage.t b/xt/author/pod-coverage.t new file mode 100644 index 0000000..66b3b64 --- /dev/null +++ b/xt/author/pod-coverage.t @@ -0,0 +1,7 @@ +#!perl +# This file was automatically generated by Dist::Zilla::Plugin::PodCoverageTests. + +use Test::Pod::Coverage 1.08; +use Pod::Coverage::TrustPod; + +all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); diff --git a/xt/author/pod-spell.t b/xt/author/pod-spell.t new file mode 100644 index 0000000..e98b029 --- /dev/null +++ b/xt/author/pod-spell.t @@ -0,0 +1,37 @@ +use strict; +use warnings; +use Test::More; + +# generated by Dist::Zilla::Plugin::Test::PodSpelling 2.007005 +use Test::Spelling 0.12; +use Pod::Wordlist; + + +add_stopwords(); +all_pod_files_spelling_ok( qw( bin lib ) ); +__DATA__ +Capture +Dagfinn +David +Golden +Graham +Ilmari +Knop +Mannsåker +Peter +Rabbitson +Tiny +UTF +Wheeler +dagolden +david +fecundf +haarg +ilmari +lib +not +prototyped +resending +ribasushi +seekable +undiagnosed diff --git a/xt/author/pod-syntax.t b/xt/author/pod-syntax.t new file mode 100644 index 0000000..e563e5d --- /dev/null +++ b/xt/author/pod-syntax.t @@ -0,0 +1,7 @@ +#!perl +# This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. +use strict; use warnings; +use Test::More; +use Test::Pod 1.41; + +all_pod_files_ok(); diff --git a/xt/author/portability.t b/xt/author/portability.t new file mode 100644 index 0000000..f6ac836 --- /dev/null +++ b/xt/author/portability.t @@ -0,0 +1,10 @@ +use strict; +use warnings; + +use Test::More; + +eval 'use Test::Portability::Files'; +plan skip_all => 'Test::Portability::Files required for testing portability' + if $@; +options(test_one_dot => 0); +run_tests(); diff --git a/xt/author/test-version.t b/xt/author/test-version.t new file mode 100644 index 0000000..247ba9a --- /dev/null +++ b/xt/author/test-version.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use Test::More; + +# generated by Dist::Zilla::Plugin::Test::Version 1.09 +use Test::Version; + +my @imports = qw( version_all_ok ); + +my $params = { + is_strict => 0, + has_version => 1, + multiple => 0, + +}; + +push @imports, $params + if version->parse( $Test::Version::VERSION ) >= version->parse('1.002'); + +Test::Version->import(@imports); + +version_all_ok; +done_testing; diff --git a/xt/release/distmeta.t b/xt/release/distmeta.t new file mode 100644 index 0000000..c2280dc --- /dev/null +++ b/xt/release/distmeta.t @@ -0,0 +1,6 @@ +#!perl +# This file was automatically generated by Dist::Zilla::Plugin::MetaTests. + +use Test::CPAN::Meta; + +meta_yaml_ok(); -- 2.34.1