diff --git a/.packit.yaml b/.packit.yaml new file mode 100644 index 0000000..4c7fd0e --- /dev/null +++ b/.packit.yaml @@ -0,0 +1,11 @@ +jobs: +- job: copr_build + metadata: + targets: &id001 [centos-stream-x86_64] + trigger: pull_request +- job: tests + metadata: + targets: *id001 + trigger: pull_request +specfile_path: SPECS/perl-Capture-Tiny.spec +upstream_ref: c8s-source-git 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..dc5cbb6 --- /dev/null +++ b/Changes @@ -0,0 +1,392 @@ +Revision history for Capture-Tiny + +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..b3dee01 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,54 @@ +# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.008. +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/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 +xt/release/minimum-version.t diff --git a/META.json b/META.json new file mode 100644 index 0000000..f68907f --- /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.008, 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", + "English" : "0", + "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::Pod" : "1.41", + "Test::Pod::Coverage" : "1.08", + "Test::Portability::Files" : "0", + "Test::Spelling" : "0.12", + "Test::Version" : "1", + "blib" : "1.01" + } + }, + "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.46" + } + }, + "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.46", + "x_authority" : "cpan:DAGOLDEN", + "x_contributors" : [ + "Dagfinn Ilmari Manns\u00e5ker ", + "David E. Wheeler ", + "fecundf ", + "Graham Knop ", + "Peter Rabbitson " + ], + "x_serialization_backend" : "Cpanel::JSON::XS version 3.0225" +} + diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..7d92c30 --- /dev/null +++ b/META.yml @@ -0,0 +1,54 @@ +--- +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.008, 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.46' +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.46' +x_authority: cpan:DAGOLDEN +x_contributors: + - 'Dagfinn Ilmari Mannsåker ' + - 'David E. Wheeler ' + - 'fecundf ' + - 'Graham Knop ' + - 'Peter Rabbitson ' +x_serialization_backend: 'YAML::Tiny version 1.69' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..92e5f94 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,72 @@ +# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.008. +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.46", + "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'} = '0'; +} + +WriteMakefile(%WriteMakefileArgs); diff --git a/README b/README new file mode 100644 index 0000000..f1b68d5 --- /dev/null +++ b/README @@ -0,0 +1,375 @@ +NAME + Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external + programs + +VERSION + version 0.46 + +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/SPECS/Capture-Tiny-0.46.tar.gz b/SPECS/Capture-Tiny-0.46.tar.gz new file mode 100644 index 0000000..4f18cd5 Binary files /dev/null and b/SPECS/Capture-Tiny-0.46.tar.gz differ diff --git a/SPECS/perl-Capture-Tiny.spec b/SPECS/perl-Capture-Tiny.spec new file mode 100644 index 0000000..8ea220b --- /dev/null +++ b/SPECS/perl-Capture-Tiny.spec @@ -0,0 +1,234 @@ +Name: perl-Capture-Tiny +Version: 0.46 +Release: 4%{?dist} +Summary: Capture STDOUT and STDERR from Perl, XS or external programs +License: ASL 2.0 +Group: Development/Libraries +URL: http://search.cpan.org/dist/Capture-Tiny/ +Source0: http://www.cpan.org/authors/id/D/DA/DAGOLDEN/Capture-Tiny-%{version}.tar.gz +BuildArch: noarch +BuildRequires: make +BuildRequires: perl-interpreter +BuildRequires: perl-devel +BuildRequires: perl-generators +BuildRequires: perl(ExtUtils::MakeMaker) >= 6.76 +BuildRequires: perl(strict) +BuildRequires: perl(warnings) +# Run-time: +BuildRequires: perl(Carp) +BuildRequires: perl(Exporter) +BuildRequires: perl(Fcntl) +BuildRequires: perl(File::Spec) +BuildRequires: perl(File::Temp) +BuildRequires: perl(IO::Handle) +# PerlIO is optional +BuildRequires: perl(Scalar::Util) +# Tests only: +BuildRequires: perl(Config) +BuildRequires: perl(IO::File) +BuildRequires: perl(lib) +BuildRequires: perl(PerlIO::scalar) +# Test::Differences is optional +BuildRequires: perl(Test::More) >= 0.62 +Requires: perl(:MODULE_COMPAT_%(eval "$(perl -V:version)"; echo $version)) + +%description +Capture::Tiny provides a simple, portable way to capture 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 handles. Yes, it even +works on Windows. Stop guessing which of a dozen capturing modules to use +in any particular situation and just use this one. + +%prep +%setup -q -n Capture-Tiny-%{version} + +%build +perl Makefile.PL INSTALLDIRS=perl NO_PACKLIST=1 +make %{?_smp_mflags} + +%install +make pure_install DESTDIR=%{buildroot} +%{_fixperms} %{buildroot}/* + +%check +make test + +%files +%license LICENSE +%doc Changes examples README Todo +%{perl_privlib}/* +%{_mandir}/man3/* + +%changelog +* Thu Feb 08 2018 Fedora Release Engineering - 0.46-4 +- Rebuilt for https://fedoraproject.org/wiki/Fedora_28_Mass_Rebuild + +* Thu Jul 27 2017 Fedora Release Engineering - 0.46-3 +- Rebuilt for https://fedoraproject.org/wiki/Fedora_27_Mass_Rebuild + +* Sun Jun 04 2017 Jitka Plesnikova - 0.46-2 +- Perl 5.26 rebuild + +* Mon Feb 27 2017 Jitka Plesnikova - 0.46-1 +- 0.46 bump + +* Sat Feb 11 2017 Fedora Release Engineering - 0.44-2 +- Rebuilt for https://fedoraproject.org/wiki/Fedora_26_Mass_Rebuild + +* Mon Aug 08 2016 Jitka Plesnikova - 0.44-1 +- 0.44 bump + +* Wed Jun 01 2016 Jitka Plesnikova - 0.42-1 +- 0.42 bump + +* Tue May 24 2016 Jitka Plesnikova - 0.40-1 +- 0.40 bump + +* Sat May 14 2016 Jitka Plesnikova - 0.36-2 +- Perl 5.24 rebuild + +* Mon Feb 29 2016 Petr Šabata - 0.36-1 +- 0.36 bump + +* Fri Feb 19 2016 Petr Šabata - 0.34-1 +- 0.34 bump, metadata changes only + +* Fri Feb 19 2016 Petr Šabata - 0.32-1 +- 0.32 bump + +* Thu Feb 04 2016 Fedora Release Engineering - 0.30-4 +- Rebuilt for https://fedoraproject.org/wiki/Fedora_24_Mass_Rebuild + +* Thu Jun 18 2015 Fedora Release Engineering - 0.30-3 +- Rebuilt for https://fedoraproject.org/wiki/Fedora_23_Mass_Rebuild + +* Wed Jun 03 2015 Jitka Plesnikova - 0.30-2 +- Perl 5.22 rebuild + +* Mon May 18 2015 Petr Šabata - 0.30-1 +- 0.30 bump +- Windows fixes only + +* Fri Feb 13 2015 Petr Šabata - 0.28-1 +- 0.28 bump + +* Wed Nov 12 2014 Petr Šabata - 0.27-1 +- 0.27 bump +- META changes only + +* Tue Nov 04 2014 Petr Šabata - 0.26-1 +- 0.26 bump +- Test suite enhancements only + +* Sun Sep 07 2014 Jitka Plesnikova - 0.25-3 +- Perl 5.20 re-rebuild of bootstrapped packages + +* Wed Aug 27 2014 Jitka Plesnikova - 0.25-2 +- Perl 5.20 rebuild + +* Mon Aug 18 2014 Petr Šabata - 0.25-1 +- 0.25 bump + +* Sat Jun 07 2014 Fedora Release Engineering - 0.24-2 +- Rebuilt for https://fedoraproject.org/wiki/Fedora_21_Mass_Rebuild + +* Mon Feb 10 2014 Petr Šabata - 0.24-1 +- 0.24 bump, fix CVE-2014-1875 + +* Thu Oct 24 2013 Petr Šabata - 0.23-1 +- 0.23 bump + +* Thu Sep 05 2013 Petr Šabata - 0.22-4 +- Avoid circular dependencies when bootstrapping (#1004376) + +* Sat Aug 03 2013 Fedora Release Engineering - 0.22-3 +- Rebuilt for https://fedoraproject.org/wiki/Fedora_20_Mass_Rebuild + +* Tue Jul 23 2013 Petr Pisar - 0.22-2 +- Perl 5.18 rebuild + +* Thu Mar 28 2013 Petr Pisar - 0.22-1 +- 0.22 bump + +* Thu Feb 14 2013 Fedora Release Engineering - 0.21-2 +- Rebuilt for https://fedoraproject.org/wiki/Fedora_19_Mass_Rebuild + +* Fri Nov 16 2012 Petr Pisar - 0.21-1 +- 0.21 bump + +* Thu Oct 04 2012 Petr Šabata - 0.20-1 +- 0.20 bump + +* Wed Aug 08 2012 Jitka Plesnikova - 0.19-1 +- 0.19 bump + +* Fri Jul 20 2012 Fedora Release Engineering - 0.18-3 +- Rebuilt for https://fedoraproject.org/wiki/Fedora_18_Mass_Rebuild + +* Sat Jun 16 2012 Petr Pisar - 0.18-2 +- Perl 5.16 rebuild + +* Mon May 07 2012 Petr Šabata - 0.18-1 +- 0.18 bump + +* Thu Feb 23 2012 Petr Šabata - 0.17-1 +- 0.17 bump + +* Mon Feb 13 2012 Petr Šabata - 0.16-1 +- 0.16 bump + +* Fri Jan 13 2012 Fedora Release Engineering - 0.15-2 +- Rebuilt for https://fedoraproject.org/wiki/Fedora_17_Mass_Rebuild + +* Mon Jan 02 2012 Petr Šabata - 0.15-1 +- 0.15 bump + +* Mon Dec 05 2011 Petr Šabata - 0.13-1 +- 0.13 bump + +* Fri Dec 02 2011 Petr Pisar - 0.12-1 +- 0.12 bump + +* Wed Jun 15 2011 Marcela Mašláňová - 0.11-2 +- Perl mass rebuild + +* Fri May 20 2011 Petr Sabata - 0.11-1 +- 0.11 bump +- Removing defattr + +* Wed Feb 09 2011 Petr Pisar - 0.10-1 +- 0.10 bump + +* Tue Feb 08 2011 Fedora Release Engineering - 0.09-2 +- Rebuilt for https://fedoraproject.org/wiki/Fedora_15_Mass_Rebuild + +* Fri Jan 28 2011 Petr Pisar - 0.09-1 +- 0.09 bump +- Remove BuildRoot stuff +- Migrate from Module::Build to ExtUtils::MakeMaker +- Install into perl core directory + +* Wed Dec 15 2010 Marcela Maslanova - 0.08-2 +- 661697 rebuild for fixing problems with vendorach/lib + +* Mon Jun 21 2010 Petr Pisar - 0.08-1 +- 0.08 bump (bug #606277) + +* Fri Apr 30 2010 Marcela Maslanova - 0.07-2 +- Mass rebuild with perl-5.12.0 + +* Wed Jan 27 2010 Marcela Mašláňová - 0.07-1 +- update + +* Mon Dec 7 2009 Stepan Kasal - 0.06-2 +- rebuild against perl 5.10.1 + +* Tue Aug 11 2009 Marcela Mašláňová - 0.06-1 +- update + +* Sat Jul 25 2009 Fedora Release Engineering - 0.05-2 +- Rebuilt for https://fedoraproject.org/wiki/Fedora_12_Mass_Rebuild + +* Mon Apr 27 2009 Marcela Mašláňová 0.05-1 +- Specfile autogenerated by cpanspec 1.78. 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..bc87cfd --- /dev/null +++ b/cpanfile @@ -0,0 +1,51 @@ +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 "English" => "0"; + 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::Pod" => "1.41"; + requires "Test::Pod::Coverage" => "1.08"; + requires "Test::Portability::Files" => "0"; + requires "Test::Spelling" => "0.12"; + requires "Test::Version" => "1"; + requires "blib" => "1.01"; +}; 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..8907ec3 --- /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.46'; +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.46 + +=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..32ad767 --- /dev/null +++ b/t/00-report-prereqs.dd @@ -0,0 +1,61 @@ +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', + 'English' => '0', + '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::Pod' => '1.41', + 'Test::Pod::Coverage' => '1.08', + 'Test::Portability::Files' => '0', + 'Test::Spelling' => '0.12', + 'Test::Version' => '1', + 'blib' => '1.01' + } + }, + '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..e338372 --- /dev/null +++ b/t/00-report-prereqs.t @@ -0,0 +1,183 @@ +#!perl + +use strict; +use warnings; + +# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.025 + +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'; +if ( $source && $HAS_CPAN_META + && (my $meta = eval { CPAN::Meta->load_file($source) } ) +) { + $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); +} +else { + $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 ( @dep_errors ) { + diag join("\n", + "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n", + "The 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..15246ec --- /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.056 + +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..d5b4c96 --- /dev/null +++ b/xt/author/critic.t @@ -0,0 +1,12 @@ +#!perl + +use strict; +use warnings; + +use Test::More; +use English qw(-no_match_vars); + +eval "use Test::Perl::Critic"; +plan skip_all => 'Test::Perl::Critic required to criticise code' if $@; +Test::Perl::Critic->import( -profile => "perlcritic.rc" ) if -e "perlcritic.rc"; +all_critic_ok(); 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..eef8e74 --- /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.007004 +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(); diff --git a/xt/release/minimum-version.t b/xt/release/minimum-version.t new file mode 100644 index 0000000..708ba15 --- /dev/null +++ b/xt/release/minimum-version.t @@ -0,0 +1,8 @@ +#!perl + +use Test::More; + +eval "use Test::MinimumVersion"; +plan skip_all => "Test::MinimumVersion required for testing minimum versions" + if $@; +all_minimum_version_ok( qq{5.010} );