Capture-Tiny-0.48/000755 000765 000024 00000000000 13267031477 014235 5ustar00davidstaff000000 000000 Capture-Tiny-0.48/LICENSE000644 000765 000024 00000026354 13267031477 015254 0ustar00davidstaff000000 000000 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. Capture-Tiny-0.48/cpanfile000644 000765 000024 00000002776 13267031477 015755 0ustar00davidstaff000000 000000 requires "Carp" => "0"; requires "Exporter" => "0"; requires "File::Spec" => "0"; requires "File::Temp" => "0"; requires "IO::Handle" => "0"; requires "Scalar::Util" => "0"; requires "perl" => "5.006"; requires "strict" => "0"; requires "warnings" => "0"; on 'test' => sub { requires "ExtUtils::MakeMaker" => "0"; requires "File::Spec" => "0"; requires "IO::File" => "0"; requires "Test::More" => "0.62"; requires "lib" => "0"; }; on 'test' => sub { recommends "CPAN::Meta" => "2.120900"; }; on 'configure' => sub { requires "ExtUtils::MakeMaker" => "6.17"; }; on 'develop' => sub { requires "Dist::Zilla" => "5"; requires "Dist::Zilla::Plugin::OSPrereqs" => "0"; requires "Dist::Zilla::Plugin::Prereqs" => "0"; requires "Dist::Zilla::Plugin::ReleaseStatus::FromVersion" => "0"; requires "Dist::Zilla::Plugin::RemovePrereqs" => "0"; requires "Dist::Zilla::PluginBundle::DAGOLDEN" => "0.072"; requires "File::Spec" => "0"; requires "File::Temp" => "0"; requires "IO::Handle" => "0"; requires "IPC::Open3" => "0"; requires "Pod::Coverage::TrustPod" => "0"; requires "Pod::Wordlist" => "0"; requires "Software::License::Apache_2_0" => "0"; requires "Test::CPAN::Meta" => "0"; requires "Test::MinimumVersion" => "0"; requires "Test::More" => "0"; requires "Test::Perl::Critic" => "0"; requires "Test::Pod" => "1.41"; requires "Test::Pod::Coverage" => "1.08"; requires "Test::Portability::Files" => "0"; requires "Test::Spelling" => "0.12"; requires "Test::Version" => "1"; }; Capture-Tiny-0.48/Changes000644 000765 000024 00000023466 13267031477 015543 0ustar00davidstaff000000 000000 Revision history for Capture-Tiny 0.48 2018-04-22 09:01:08+02:00 Europe/Oslo - No changes from 0.47-TRIAL 0.47 2017-07-26 10:34:24-04:00 America/New_York (TRIAL RELEASE) [Fixed] - Appends PID to random file names for tee signalling to avoid random name collision when used in multiple forked children. 0.46 2017-02-25 14:19:22-05:00 America/New_York - No changes from 0.45-TRIAL 0.45 2017-02-23 13:22:43-05:00 America/New_York (TRIAL RELEASE) [Internal] - Avoid variable shadowing to improve debuggability. 0.44 2016-08-05 13:40:33-04:00 America/New_York [Docs] - Note that dropping privileges during a capture can lead to temporary files not cleaned up. 0.42 2016-05-31 12:40:10-04:00 America/New_York - No changes from 0.41 0.41 2016-05-23 11:58:15-04:00 America/New_York (TRIAL RELEASE) [Fixed] - Fixed some failing tests when STDIN is routed to /dev/null 0.40 2016-05-23 11:42:35-04:00 America/New_York - No changes from 0.39 0.39 2016-05-02 10:21:48-04:00 America/New_York (TRIAL RELEASE) [Fixed] - Fix in 0.37 tickled a very obscure regular expressions bug in perl < 5.18; should now be fixed. 0.37 2016-05-02 07:08:31-04:00 America/New_York (TRIAL RELEASE) [Fixed] - Skip some tests if locale can't be determined. 0.36 2016-02-28 21:36:57-05:00 America/New_York [Docs] - Fixed typos. 0.34 2016-02-18 23:26:13-05:00 America/New_York [Fixed] - Removed spurious JSON::PP dependency added by a broken Dist::Zilla plugin. 0.32 2016-02-18 10:12:02-05:00 America/New_York [Docs] - Changed internal formatting of documentation [Changes] - No functional changes from 0.31 0.31 2016-02-14 07:33:50-07:00 America/Mazatlan (TRIAL RELEASE) [Fixed] - Application of layers to handles during and after capture now attempts to more accurately duplicate the original layers, including potential duplicate layers. Because of the unusual ways that layers are ordered and applied, exact duplication is not guaranteeed, but this should be better that what Capture::Tiny did before. - Avoids a hard crash on Windows with Perl < 5.20 if a fork occurs in a capture block. Also documented the risks and lack of support for forks in capture blocks. 0.30 2015-05-15 20:43:54-04:00 America/New_York No changes from 0.29 0.29 2015-04-19 18:36:24+02:00 Europe/Berlin (TRIAL RELEASE) Fixed: - Fix double filehandle close error with tee on Windows (which started warning during the perl 5.21.x series, causing tests to fail) 0.28 2015-02-11 06:39:51-05:00 America/New_York Tests: - Removes test that optionally uses Inline::C to avoid spurious test failures. Also Inline::C had become a fairly heavy (if optional) dependency. Docs: - Clarify that PERL_CAPTURE_TINY_TIMEOUT is an internal control, not a timeout of the code reference being captured. 0.27 2014-11-04 23:10:44-05:00 America/New_York Prereqs: - Make Inline::C recommended, not required 0.26 2014-11-04 06:55:15-05:00 America/New_York Tests: - Actually check for Inline::C in tests, not just Inline 0.25 2014-08-16 10:08:42-04:00 America/New_York Prereqs: - Amended recommended modules to list Inline::C rather than Inline 0.24 2014-02-06 17:15:37-05:00 America/New_York Fixed: - Closed security hole in use of semaphore file in /tmp; now opens the semaphore file using O_CREAT|O_EXCL 0.23 2013-10-20 11:25:34 America/New_York Fixed: - minimum Perl prereq is back to 5.6 (but $diety help you if you're still stuck on 5.6) Documented: - Added warning about using @_ in a capture block 0.22 2013-03-27 15:50:29 America/New_York Documented: - Issue tracker is now github 0.21 2012-11-14 19:04:49 America/New_York Changed: - Skips tee and leak tests for closed STDIN on Perl prior to 5.12 when PERL_UNICODE=D. Documented lack of support as a known issue. - Isolated tee subprocesses from effects of PERL_UNICODE as a precaution (though this did not fix the above issue). - Improved layer detection for handles proxied due to being closed or tied. 0.20 2012-09-19 13:20:57 America/New_York Fixed: - Nested merged captures that include an external program call no longer leak STDERR to the outer scope [rt.cpan.org #79376] 0.19 2012-08-06 20:26:34 America/New_York Fixed: - Work around rt.perl.org #114404 by forcing PerlIO layers back on original handles [rt.cpan.org #78819] 0.18 2012-05-04 16:31:53 America/New_York Added: - When capture or tee are called in void context, Capture::Tiny skips reading back from the capture handles if it can do so safely 0.17_52 2012-03-09 11:45:19 EST5EDT Fixed: - Tied STDIN is always localized before redirections to avoid tees hanging on MSWin32 - Copying and reopening STDIN is necessary to avoid tees hanging on MSWin32. 0.17_51 2012-03-07 18:22:34 EST5EDT Fixed: - Avoids reopening STDIN while setting up a capture, which avoids some problems with pathological tied filehandle implementations such as in FCGI Tested: - Re-enabled tied STDIN testing for MSWin32 to see if changes above avoid crashes seen historically 0.17 2012-02-22 08:07:41 EST5EDT Fixed: - Added a workaround for failing t/08-stdin-closed.t under blead perl / 5.15.8 [rt.perl.org #111070] Documented: - Clarified some limitations; added a link to CPAN Testers Matrix; removed redundant BUGS section; standardized terminology Tested: - Added a test using Inline::C to print to stdout and stderr in response to rt.cpan.org #71701 0.16 2012-02-12 21:04:24 EST5EDT Documented: - Noted problems and workaround for FCGI's pathological tied STDIN [rt.cpan.org #74681; thank you Karl Gaissmaier for testing the workaround] 0.15 2011-12-23 11:10:47 EST5EDT Fixed: - Repeated captures from a custom filehandle would return undef instead of the empty string (and would warn). This has been fixed. [rt.cpan.org #73374 part two. Thank you to Philipp Herz for help in reproducing this bug.] Other: - Commented out debugging code for slightly less runtime overhead 0.14 2011-12-22 10:14:09 EST5EDT Added: - Capturing with custom filehandles will return only newly appended output instead of everything already in the file. [rt.cpan.org #73374] 0.13 2011-12-02 13:39:00 EST5EDT Fixed: - Fixed t/18-custom-capture.t failures on Windows due to tempfile removal problems in the testfile 0.12 2011-12-01 16:58:05 EST5EDT Added: - New functions capture_stdout, capture_stderr, tee_stdout, tee_stderr [rt.cpan.org #60515] - Capture functions also returns the return values from the executed coderef [rt.cpan.org #61794, adapted from patch by Christian Walde] - Capture functions take optional custom filehandles for capturing via named files instead of anonymous ones [inspired by Christian Walde] Fixed: - Tied filehandles based on Tie::StdHandle can now use the ":utf8" layer; removed remaining TODO tests; adds Scalar::Util as a dependency Changed: - When Time::HiRes::usleep is available, tee operations will sleep during the busy-loop waiting for tee processes to be ready [rt.cpan.org #67858] 0.11 2011-05-19 23:34:23 America/New_York Fixed: - Tests will not use Test::Differences version 0.60 or greater 0.10 2011-02-07 07:01:44 EST5EDT Fixed: - Setting PERL_CAPTURE_TINY_TIMEOUT to 0 will disable timeouts 0.09 2011-01-27 23:52:16 EST5EDT Added: - Added support for $ENV{PERL_CAPTURE_TINY_TIMEOUT} to control the timeout period under 'tee'; tests set not to timeout to avoid false FAIL reports on overloaded virtual machine smokers Fixed: - $@ set within a captured block is no longer lost when the capture is completed; likewise, the initial value of $@ is not lost during capture (when no subsequent error occurs) (RT #65139) 0.08 Sun Jun 20 19:13:19 EDT 2010 Fixed: - Exceptions in captured coderef are caught, then handles are restored before the exception is rethrown (RT #58208) 0.07 Sun Jan 24 00:18:45 EST 2010 Fixed: - Changed test for $? preservation to be more portable - Dropped support for Perl 5.8.0 specifically due to excessive bugs. Tests will bail out. (5.6.X is still supported) 0.06 Thu May 7 06:54:53 EDT 2009 Fixed: - On Win32, subprocesses now close themselves on EOF instead of being killed with a signal 0.05_51 Tue Apr 21 07:00:38 EDT 2009 Added: - Support for wide characters on handles opened to utf8 - Support for STDOUT, STDERR or STDIN opened to in-memory files (open to scalar reference) or tied, albeit with some limitations Testing: - Verify that $? is preserved during capture { system(@cmd) }; 0.05 Tue Mar 3 06:56:05 EST 2009 Fixed: - On Win32, increased a delay waiting for buffers to flush to avoid losing final output during tee() 0.04 Wed Feb 25 09:25:27 EST 2009 Added: - Can capture/tee even if STDIN, STDOUT or STDERR are closed prior to capture/tee block - Generally, added more error handling Fixed: - Will timeout instead of hang if subprocesses fail to start 0.03 Fri Feb 20 13:03:08 EST 2009 Added: - capture_merged() and tee_merged() Fixed: - Tests skip if not Win32 and no fork() (rather than Build.PL and Makefile.PL failing); this allows capture() on odd platforms, even if fork doesn't work 0.02 Tue Feb 17 17:24:35 EST 2009 Fixed: - Bug recovering output when STDOUT is empty (reported by Vincent Pit) - Removed Fatal.pm to avoid global action-at-a-distance 0.01 Fri Feb 13 23:15:19 EST 2009 Added: - 'capture' and 'tee' functions # vim: set ts=2 sts=2 sw=2 et tw=75: Capture-Tiny-0.48/MANIFEST000644 000765 000024 00000001773 13267031477 015376 0ustar00davidstaff000000 000000 # This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.012. CONTRIBUTING.mkdn Changes LICENSE MANIFEST META.json META.yml Makefile.PL README Todo cpanfile dist.ini examples/rt-58208.pl examples/tee.pl lib/Capture/Tiny.pm perlcritic.rc t/00-report-prereqs.dd t/00-report-prereqs.t t/01-Capture-Tiny.t t/02-capture.t t/03-tee.t t/06-stdout-closed.t t/07-stderr-closed.t t/08-stdin-closed.t t/09-preserve-exit-code.t t/10-stdout-string.t t/11-stderr-string.t t/12-stdin-string.t t/13-stdout-tied.t t/14-stderr-tied.t t/15-stdin-tied.t t/16-catch-errors.t t/17-pass-results.t t/18-custom-capture.t t/19-relayering.t t/20-stdout-badtie.t t/21-stderr-badtie.t t/22-stdin-badtie.t t/23-all-tied.t t/24-all-badtied.t t/25-cap-fork.t t/lib/Cases.pm t/lib/TieEvil.pm t/lib/TieLC.pm t/lib/Utils.pm xt/author/00-compile.t xt/author/critic.t xt/author/minimum-version.t xt/author/pod-coverage.t xt/author/pod-spell.t xt/author/pod-syntax.t xt/author/portability.t xt/author/test-version.t xt/release/distmeta.t Capture-Tiny-0.48/perlcritic.rc000644 000765 000024 00000001166 13267031477 016727 0ustar00davidstaff000000 000000 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] Capture-Tiny-0.48/CONTRIBUTING.mkdn000644 000765 000024 00000005751 13267031477 017027 0ustar00davidstaff000000 000000 ## 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/ Capture-Tiny-0.48/t/000755 000765 000024 00000000000 13267031477 014500 5ustar00davidstaff000000 000000 Capture-Tiny-0.48/xt/000755 000765 000024 00000000000 13267031477 014670 5ustar00davidstaff000000 000000 Capture-Tiny-0.48/README000644 000765 000024 00000032177 13267031477 015127 0ustar00davidstaff000000 000000 NAME Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs VERSION version 0.48 SYNOPSIS use Capture::Tiny ':all'; # capture from external command ($stdout, $stderr, $exit) = capture { system( $cmd, @args ); }; # capture from arbitrary code (Perl or external) ($stdout, $stderr, @result) = capture { # your code here }; # capture partial or merged output $stdout = capture_stdout { ... }; $stderr = capture_stderr { ... }; $merged = capture_merged { ... }; # tee output ($stdout, $stderr) = tee { # your code here }; $stdout = tee_stdout { ... }; $stderr = tee_stderr { ... }; $merged = tee_merged { ... }; DESCRIPTION Capture::Tiny provides a simple, portable way to capture almost anything sent to STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or from an external program. Optionally, output can be teed so that it is captured while being passed through to the original filehandles. Yes, it even works on Windows (usually). Stop guessing which of a dozen capturing modules to use in any particular situation and just use this one. USAGE The following functions are available. None are exported by default. capture ($stdout, $stderr, @result) = capture \&code; $stdout = capture \&code; The "capture" function takes a code reference and returns what is sent to STDOUT and STDERR as well as any return values from the code reference. In scalar context, it returns only STDOUT. If no output was received for a filehandle, it returns an empty string for that filehandle. Regardless of calling context, all output is captured -- nothing is passed to the existing filehandles. It is prototyped to take a subroutine reference as an argument. Thus, it can be called in block form: ($stdout, $stderr) = capture { # your code here ... }; Note that the coderef is evaluated in list context. If you wish to force scalar context on the return value, you must use the "scalar" keyword. ($stdout, $stderr, $count) = capture { my @list = qw/one two three/; return scalar @list; # $count will be 3 }; Also note that within the coderef, the @_ variable will be empty. So don't use arguments from a surrounding subroutine without copying them to an array first: sub wont_work { my ($stdout, $stderr) = capture { do_stuff( @_ ) }; # WRONG ... } sub will_work { my @args = @_; my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT ... } Captures are normally done to an anonymous temporary filehandle. To capture via a named file (e.g. to externally monitor a long-running capture), provide custom filehandles as a trailing list of option pairs: my $out_fh = IO::File->new("out.txt", "w+"); my $err_fh = IO::File->new("out.txt", "w+"); capture { ... } stdout => $out_fh, stderr => $err_fh; The filehandles must be read/write and seekable. Modifying the files or filehandles during a capture operation will give unpredictable results. Existing IO layers on them may be changed by the capture. When called in void context, "capture" saves memory and time by not reading back from the capture handles. capture_stdout ($stdout, @result) = capture_stdout \&code; $stdout = capture_stdout \&code; The "capture_stdout" function works just like "capture" except only STDOUT is captured. STDERR is not captured. capture_stderr ($stderr, @result) = capture_stderr \&code; $stderr = capture_stderr \&code; The "capture_stderr" function works just like "capture" except only STDERR is captured. STDOUT is not captured. capture_merged ($merged, @result) = capture_merged \&code; $merged = capture_merged \&code; The "capture_merged" function works just like "capture" except STDOUT and STDERR are merged. (Technically, STDERR is redirected to the same capturing handle as STDOUT before executing the function.) Caution: STDOUT and STDERR output in the merged result are not guaranteed to be properly ordered due to buffering. tee ($stdout, $stderr, @result) = tee \&code; $stdout = tee \&code; The "tee" function works just like "capture", except that output is captured as well as passed on to the original STDOUT and STDERR. When called in void context, "tee" saves memory and time by not reading back from the capture handles, except when the original STDOUT OR STDERR were tied or opened to a scalar handle. tee_stdout ($stdout, @result) = tee_stdout \&code; $stdout = tee_stdout \&code; The "tee_stdout" function works just like "tee" except only STDOUT is teed. STDERR is not teed (output goes to STDERR as usual). tee_stderr ($stderr, @result) = tee_stderr \&code; $stderr = tee_stderr \&code; The "tee_stderr" function works just like "tee" except only STDERR is teed. STDOUT is not teed (output goes to STDOUT as usual). tee_merged ($merged, @result) = tee_merged \&code; $merged = tee_merged \&code; The "tee_merged" function works just like "capture_merged" except that output is captured as well as passed on to STDOUT. Caution: STDOUT and STDERR output in the merged result are not guaranteed to be properly ordered due to buffering. LIMITATIONS Portability Portability is a goal, not a guarantee. "tee" requires fork, except on Windows where "system(1, @cmd)" is used instead. Not tested on any particularly esoteric platforms yet. See the CPAN Testers Matrix for test result by platform. PerlIO layers Capture::Tiny does its best to preserve PerlIO layers such as ':utf8' or ':crlf' when capturing (only for Perl 5.8.1+) . Layers should be applied to STDOUT or STDERR *before* the call to "capture" or "tee". This may not work for tied filehandles (see below). Modifying filehandles before capturing Generally speaking, you should do little or no manipulation of the standard IO filehandles prior to using Capture::Tiny. In particular, closing, reopening, localizing or tying standard filehandles prior to capture may cause a variety of unexpected, undesirable and/or unreliable behaviors, as described below. Capture::Tiny does its best to compensate for these situations, but the results may not be what you desire. Closed filehandles Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously closed. However, since they will be reopened to capture or tee output, any code within the captured block that depends on finding them closed will, of course, not find them to be closed. If they started closed, Capture::Tiny will close them again when the capture block finishes. Note that this reopening will happen even for STDIN or a filehandle not being captured to ensure that the filehandle used for capture is not opened to file descriptor 0, as this causes problems on various platforms. Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles and also breaks tee() for undiagnosed reasons. So don't do that. Localized filehandles If code localizes any of Perl's standard filehandles before capturing, the capture will affect the localized filehandles and not the original ones. External system calls are not affected by localizing a filehandle in Perl and will continue to send output to the original filehandles (which will thus not be captured). Scalar filehandles If STDOUT or STDERR are reopened to scalar filehandles prior to the call to "capture" or "tee", then Capture::Tiny will override the output filehandle for the duration of the "capture" or "tee" call and then, for "tee", send captured output to the output filehandle after the capture is complete. (Requires Perl 5.8) Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar reference, but note that external processes will not be able to read from such a handle. Capture::Tiny tries to ensure that external processes will read from the null device instead, but this is not guaranteed. Tied output filehandles If STDOUT or STDERR are tied prior to the call to "capture" or "tee", then Capture::Tiny will attempt to override the tie for the duration of the "capture" or "tee" call and then send captured output to the tied filehandle after the capture is complete. (Requires Perl 5.8) Capture::Tiny may not succeed resending UTF-8 encoded data to a tied STDOUT or STDERR filehandle. Characters may appear as bytes. If the tied filehandle is based on Tie::StdHandle, then Capture::Tiny will attempt to determine appropriate layers like ":utf8" from the underlying filehandle and do the right thing. Tied input filehandle Capture::Tiny attempts to preserve the semantics of tied STDIN, but this requires Perl 5.8 and is not entirely predictable. External processes will not be able to read from such a handle. Unless having STDIN tied is crucial, it may be safest to localize STDIN when capturing: my ($out, $err) = do { local *STDIN; capture { ... } }; Modifying filehandles during a capture Attempting to modify STDIN, STDOUT or STDERR *during* "capture" or "tee" is almost certainly going to cause problems. Don't do that. Forking inside a capture Forks aren't portable. The behavior of filehandles during a fork is even less so. If Capture::Tiny detects that a fork has occurred within a capture, it will shortcut in the child process and return empty strings for captures. Other problems may occur in the child or parent, as well. Forking in a capture block is not recommended. Using threads Filehandles are global. Mixing up I/O and captures in different threads without coordination is going to cause problems. Besides, threads are officially discouraged. Dropping privileges during a capture If you drop privileges during a capture, temporary files created to facilitate the capture may not be cleaned up afterwards. No support for Perl 5.8.0 It's just too buggy when it comes to layers and UTF-8. Perl 5.8.1 or later is recommended. Limited support for Perl 5.6 Perl 5.6 predates PerlIO. UTF-8 data may not be captured correctly. ENVIRONMENT PERL_CAPTURE_TINY_TIMEOUT Capture::Tiny uses subprocesses internally for "tee". By default, Capture::Tiny will timeout with an error if such subprocesses are not ready to receive data within 30 seconds (or whatever is the value of $Capture::Tiny::TIMEOUT). An alternate timeout may be specified by setting the "PERL_CAPTURE_TINY_TIMEOUT" environment variable. Setting it to zero will disable timeouts. NOTE, this does not timeout the code reference being captured -- this only prevents Capture::Tiny itself from hanging your process waiting for its child processes to be ready to proceed. SEE ALSO This module was inspired by IO::CaptureOutput, which provides similar functionality without the ability to tee output and with more complicated code and API. IO::CaptureOutput does not handle layers or most of the unusual cases described in the "Limitations" section and I no longer recommend it. There are many other CPAN modules that provide some sort of output capture, albeit with various limitations that make them appropriate only in particular circumstances. I'm probably missing some. The long list is provided to show why I felt Capture::Tiny was necessary. * IO::Capture * IO::Capture::Extended * IO::CaptureOutput * IPC::Capture * IPC::Cmd * IPC::Open2 * IPC::Open3 * IPC::Open3::Simple * IPC::Open3::Utils * IPC::Run * IPC::Run::SafeHandles * IPC::Run::Simple * IPC::Run3 * IPC::System::Simple * Tee * IO::Tee * File::Tee * Filter::Handle * Tie::STDERR * Tie::STDOUT * Test::Output SUPPORT Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at . You will be notified automatically of any progress on your issue. Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. git clone https://github.com/dagolden/Capture-Tiny.git AUTHOR David Golden CONTRIBUTORS * Dagfinn Ilmari Mannsåker * David E. Wheeler * fecundf * Graham Knop * Peter Rabbitson COPYRIGHT AND LICENSE This software is Copyright (c) 2009 by David Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 Capture-Tiny-0.48/Todo000644 000765 000024 00000000565 13267031477 015073 0ustar00davidstaff000000 000000 # 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 Capture-Tiny-0.48/examples/000755 000765 000024 00000000000 13267031477 016053 5ustar00davidstaff000000 000000 Capture-Tiny-0.48/META.yml000644 000765 000024 00000002537 13267031477 015515 0ustar00davidstaff000000 000000 --- abstract: 'Capture STDOUT and STDERR from Perl, XS or external programs' author: - 'David Golden ' build_requires: ExtUtils::MakeMaker: '0' File::Spec: '0' IO::File: '0' Test::More: '0.62' lib: '0' configure_requires: ExtUtils::MakeMaker: '6.17' dynamic_config: 1 generated_by: 'Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010' license: apache meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Capture-Tiny no_index: directory: - corpus - examples - t - xt package: - DB provides: Capture::Tiny: file: lib/Capture/Tiny.pm version: '0.48' requires: Carp: '0' Exporter: '0' File::Spec: '0' File::Temp: '0' IO::Handle: '0' Scalar::Util: '0' perl: '5.006' strict: '0' warnings: '0' resources: bugtracker: https://github.com/dagolden/Capture-Tiny/issues homepage: https://github.com/dagolden/Capture-Tiny repository: https://github.com/dagolden/Capture-Tiny.git version: '0.48' x_authority: cpan:DAGOLDEN x_contributors: - 'Dagfinn Ilmari Mannsåker ' - 'David E. Wheeler ' - 'fecundf ' - 'Graham Knop ' - 'Peter Rabbitson ' x_generated_by_perl: v5.26.1 x_serialization_backend: 'YAML::Tiny version 1.70' Capture-Tiny-0.48/lib/000755 000765 000024 00000000000 13267031477 015003 5ustar00davidstaff000000 000000 Capture-Tiny-0.48/Makefile.PL000644 000765 000024 00000003154 13267031477 016212 0ustar00davidstaff000000 000000 # This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.012. use strict; use warnings; use 5.006; use ExtUtils::MakeMaker 6.17; my %WriteMakefileArgs = ( "ABSTRACT" => "Capture STDOUT and STDERR from Perl, XS or external programs", "AUTHOR" => "David Golden ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => "6.17" }, "DISTNAME" => "Capture-Tiny", "LICENSE" => "apache", "MIN_PERL_VERSION" => "5.006", "NAME" => "Capture::Tiny", "PREREQ_PM" => { "Carp" => 0, "Exporter" => 0, "File::Spec" => 0, "File::Temp" => 0, "IO::Handle" => 0, "Scalar::Util" => 0, "strict" => 0, "warnings" => 0 }, "TEST_REQUIRES" => { "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "IO::File" => 0, "Test::More" => "0.62", "lib" => 0 }, "VERSION" => "0.48", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "Carp" => 0, "Exporter" => 0, "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "File::Temp" => 0, "IO::File" => 0, "IO::Handle" => 0, "Scalar::Util" => 0, "Test::More" => "0.62", "lib" => 0, "strict" => 0, "warnings" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; if ( $^O eq 'MSWin32' ) { $WriteMakefileArgs{PREREQ_PM}{'Win32API::File'} = $FallbackPrereqs{'Win32API::File'} = '0'; } WriteMakefile(%WriteMakefileArgs); Capture-Tiny-0.48/META.json000644 000765 000024 00000006373 13267031477 015667 0ustar00davidstaff000000 000000 { "abstract" : "Capture STDOUT and STDERR from Perl, XS or external programs", "author" : [ "David Golden " ], "dynamic_config" : 1, "generated_by" : "Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010", "license" : [ "apache_2_0" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Capture-Tiny", "no_index" : { "directory" : [ "corpus", "examples", "t", "xt" ], "package" : [ "DB" ] }, "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.17" } }, "develop" : { "requires" : { "Dist::Zilla" : "5", "Dist::Zilla::Plugin::OSPrereqs" : "0", "Dist::Zilla::Plugin::Prereqs" : "0", "Dist::Zilla::Plugin::ReleaseStatus::FromVersion" : "0", "Dist::Zilla::Plugin::RemovePrereqs" : "0", "Dist::Zilla::PluginBundle::DAGOLDEN" : "0.072", "File::Spec" : "0", "File::Temp" : "0", "IO::Handle" : "0", "IPC::Open3" : "0", "Pod::Coverage::TrustPod" : "0", "Pod::Wordlist" : "0", "Software::License::Apache_2_0" : "0", "Test::CPAN::Meta" : "0", "Test::MinimumVersion" : "0", "Test::More" : "0", "Test::Perl::Critic" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08", "Test::Portability::Files" : "0", "Test::Spelling" : "0.12", "Test::Version" : "1" } }, "runtime" : { "requires" : { "Carp" : "0", "Exporter" : "0", "File::Spec" : "0", "File::Temp" : "0", "IO::Handle" : "0", "Scalar::Util" : "0", "perl" : "5.006", "strict" : "0", "warnings" : "0" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "ExtUtils::MakeMaker" : "0", "File::Spec" : "0", "IO::File" : "0", "Test::More" : "0.62", "lib" : "0" } } }, "provides" : { "Capture::Tiny" : { "file" : "lib/Capture/Tiny.pm", "version" : "0.48" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/dagolden/Capture-Tiny/issues" }, "homepage" : "https://github.com/dagolden/Capture-Tiny", "repository" : { "type" : "git", "url" : "https://github.com/dagolden/Capture-Tiny.git", "web" : "https://github.com/dagolden/Capture-Tiny" } }, "version" : "0.48", "x_authority" : "cpan:DAGOLDEN", "x_contributors" : [ "Dagfinn Ilmari Manns\u00e5ker ", "David E. Wheeler ", "fecundf ", "Graham Knop ", "Peter Rabbitson " ], "x_generated_by_perl" : "v5.26.1", "x_serialization_backend" : "Cpanel::JSON::XS version 3.0239" } Capture-Tiny-0.48/dist.ini000644 000765 000024 00000001067 13267031477 015705 0ustar00davidstaff000000 000000 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 Capture-Tiny-0.48/lib/Capture/000755 000765 000024 00000000000 13267031477 016406 5ustar00davidstaff000000 000000 Capture-Tiny-0.48/lib/Capture/Tiny.pm000644 000765 000024 00000071730 13267031477 017677 0ustar00davidstaff000000 000000 use 5.006; use strict; use warnings; package Capture::Tiny; # ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs our $VERSION = '0.48'; use Carp (); use Exporter (); use IO::Handle (); use File::Spec (); use File::Temp qw/tempfile tmpnam/; use Scalar::Util qw/reftype blessed/; # Get PerlIO or fake it BEGIN { local $@; eval { require PerlIO; PerlIO->can('get_layers') } or *PerlIO::get_layers = sub { return () }; } #--------------------------------------------------------------------------# # create API subroutines and export them # [do STDOUT flag, do STDERR flag, do merge flag, do tee flag] #--------------------------------------------------------------------------# my %api = ( capture => [1,1,0,0], capture_stdout => [1,0,0,0], capture_stderr => [0,1,0,0], capture_merged => [1,1,1,0], tee => [1,1,0,1], tee_stdout => [1,0,0,1], tee_stderr => [0,1,0,1], tee_merged => [1,1,1,1], ); for my $sub ( keys %api ) { my $args = join q{, }, @{$api{$sub}}; eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic } our @ISA = qw/Exporter/; our @EXPORT_OK = keys %api; our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); #--------------------------------------------------------------------------# # constants and fixtures #--------------------------------------------------------------------------# my $IS_WIN32 = $^O eq 'MSWin32'; ##our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG}; ## ##my $DEBUGFH; ##open $DEBUGFH, "> DEBUG" if $DEBUG; ## ##*_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0}; our $TIMEOUT = 30; #--------------------------------------------------------------------------# # command to tee output -- the argument is a filename that must # be opened to signal that the process is ready to receive input. # This is annoying, but seems to be the best that can be done # as a simple, portable IPC technique #--------------------------------------------------------------------------# my @cmd = ($^X, '-C0', '-e', <<'HERE'); use Fcntl; $SIG{HUP}=sub{exit}; if ( my $fn=shift ) { sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!; print {$fh} $$; close $fh; } my $buf; while (sysread(STDIN, $buf, 2048)) { syswrite(STDOUT, $buf); syswrite(STDERR, $buf); } HERE #--------------------------------------------------------------------------# # filehandle manipulation #--------------------------------------------------------------------------# sub _relayer { my ($fh, $apply_layers) = @_; # _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n"); # eliminate pseudo-layers binmode( $fh, ":raw" ); # strip off real layers until only :unix is left while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) { binmode( $fh, ":pop" ); } # apply other layers my @to_apply = @$apply_layers; shift @to_apply; # eliminate initial :unix # _debug("# applying layers (unix @to_apply) to @{[fileno $fh]}\n"); binmode($fh, ":" . join(":",@to_apply)); } sub _name { my $glob = shift; no strict 'refs'; ## no critic return *{$glob}{NAME}; } sub _open { open $_[0], $_[1] or Carp::confess "Error from open(" . join(q{, }, @_) . "): $!"; # _debug( "# open " . join( ", " , map { defined $_ ? _name($_) : 'undef' } @_ ) . " as " . fileno( $_[0] ) . "\n" ); } sub _close { # _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' ) . " on " . fileno( $_[0] ) . "\n" ); close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!"; } my %dup; # cache this so STDIN stays fd0 my %proxy_count; sub _proxy_std { my %proxies; if ( ! defined fileno STDIN ) { $proxy_count{stdin}++; if (defined $dup{stdin}) { _open \*STDIN, "<&=" . fileno($dup{stdin}); # _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); } else { _open \*STDIN, "<" . File::Spec->devnull; # _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); _open $dup{stdin} = IO::Handle->new, "<&=STDIN"; } $proxies{stdin} = \*STDIN; binmode(STDIN, ':utf8') if $] >= 5.008; ## no critic } if ( ! defined fileno STDOUT ) { $proxy_count{stdout}++; if (defined $dup{stdout}) { _open \*STDOUT, ">&=" . fileno($dup{stdout}); # _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); } else { _open \*STDOUT, ">" . File::Spec->devnull; # _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); _open $dup{stdout} = IO::Handle->new, ">&=STDOUT"; } $proxies{stdout} = \*STDOUT; binmode(STDOUT, ':utf8') if $] >= 5.008; ## no critic } if ( ! defined fileno STDERR ) { $proxy_count{stderr}++; if (defined $dup{stderr}) { _open \*STDERR, ">&=" . fileno($dup{stderr}); # _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); } else { _open \*STDERR, ">" . File::Spec->devnull; # _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); _open $dup{stderr} = IO::Handle->new, ">&=STDERR"; } $proxies{stderr} = \*STDERR; binmode(STDERR, ':utf8') if $] >= 5.008; ## no critic } return %proxies; } sub _unproxy { my (%proxies) = @_; # _debug( "# unproxying: " . join(" ", keys %proxies) . "\n" ); for my $p ( keys %proxies ) { $proxy_count{$p}--; # _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" ); if ( ! $proxy_count{$p} ) { _close $proxies{$p}; _close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup delete $dup{$p}; } } } sub _copy_std { my %handles; for my $h ( qw/stdout stderr stdin/ ) { next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied my $redir = $h eq 'stdin' ? "<&" : ">&"; _open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN" } return \%handles; } # In some cases we open all (prior to forking) and in others we only open # the output handles (setting up redirection) sub _open_std { my ($handles) = @_; _open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin}; _open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout}; _open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr}; } #--------------------------------------------------------------------------# # private subs #--------------------------------------------------------------------------# sub _start_tee { my ($which, $stash) = @_; # $which is "stdout" or "stderr" # setup pipes $stash->{$_}{$which} = IO::Handle->new for qw/tee reader/; pipe $stash->{reader}{$which}, $stash->{tee}{$which}; # _debug( "# pipe for $which\: " . _name($stash->{tee}{$which}) . " " . fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which}) . " " . fileno( $stash->{reader}{$which}) . "\n" ); select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush # setup desired redirection for parent and child $stash->{new}{$which} = $stash->{tee}{$which}; $stash->{child}{$which} = { stdin => $stash->{reader}{$which}, stdout => $stash->{old}{$which}, stderr => $stash->{capture}{$which}, }; # flag file is used to signal the child is ready $stash->{flag_files}{$which} = scalar( tmpnam() ) . $$; # execute @cmd as a separate process if ( $IS_WIN32 ) { my $old_eval_err=$@; undef $@; eval "use Win32API::File qw/GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ "; # _debug( "# Win32API::File loaded\n") unless $@; my $os_fhandle = GetOsFHandle( $stash->{tee}{$which} ); # _debug( "# Couldn't get OS handle: " . fileLastError() . "\n") if ! defined $os_fhandle || $os_fhandle == INVALID_HANDLE_VALUE(); my $result = SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0); # _debug( $result ? "# set no-inherit flag on $which tee\n" : ("# can't disable tee handle flag inherit: " . fileLastError() . "\n")); _open_std( $stash->{child}{$which} ); $stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which}); # not restoring std here as it all gets redirected again shortly anyway $@=$old_eval_err; } else { # use fork _fork_exec( $which, $stash ); } } sub _fork_exec { my ($which, $stash) = @_; # $which is "stdout" or "stderr" my $pid = fork; if ( not defined $pid ) { Carp::confess "Couldn't fork(): $!"; } elsif ($pid == 0) { # child # _debug( "# in child process ...\n" ); untie *STDIN; untie *STDOUT; untie *STDERR; _close $stash->{tee}{$which}; # _debug( "# redirecting handles in child ...\n" ); _open_std( $stash->{child}{$which} ); # _debug( "# calling exec on command ...\n" ); exec @cmd, $stash->{flag_files}{$which}; } $stash->{pid}{$which} = $pid } my $have_usleep = eval "use Time::HiRes 'usleep'; 1"; sub _files_exist { return 1 if @_ == grep { -f } @_; Time::HiRes::usleep(1000) if $have_usleep; return 0; } sub _wait_for_tees { my ($stash) = @_; my $start = time; my @files = values %{$stash->{flag_files}}; my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT} ? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT; 1 until _files_exist(@files) || ($timeout && (time - $start > $timeout)); Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files); unlink $_ for @files; } sub _kill_tees { my ($stash) = @_; if ( $IS_WIN32 ) { # _debug( "# closing handles\n"); close($_) for values %{ $stash->{tee} }; # _debug( "# waiting for subprocesses to finish\n"); my $start = time; 1 until wait == -1 || (time - $start > 30); } else { _close $_ for values %{ $stash->{tee} }; waitpid $_, 0 for values %{ $stash->{pid} }; } } sub _slurp { my ($name, $stash) = @_; my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/; # _debug( "# slurping captured $name from " . fileno($fh) . " at pos $pos with layers: @{[PerlIO::get_layers($fh)]}\n"); seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n"; my $text = do { local $/; scalar readline $fh }; return defined($text) ? $text : ""; } #--------------------------------------------------------------------------# # _capture_tee() -- generic main sub for capturing or teeing #--------------------------------------------------------------------------# sub _capture_tee { # _debug( "# starting _capture_tee with (@_)...\n" ); my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_; my %do = ($do_stdout ? (stdout => 1) : (), $do_stderr ? (stderr => 1) : ()); Carp::confess("Custom capture options must be given as key/value pairs\n") unless @opts % 2 == 0; my $stash = { capture => { @opts } }; for ( keys %{$stash->{capture}} ) { my $fh = $stash->{capture}{$_}; Carp::confess "Custom handle for $_ must be seekable\n" unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable")); } # save existing filehandles and setup captures local *CT_ORIG_STDIN = *STDIN ; local *CT_ORIG_STDOUT = *STDOUT; local *CT_ORIG_STDERR = *STDERR; # find initial layers my %layers = ( stdin => [PerlIO::get_layers(\*STDIN) ], stdout => [PerlIO::get_layers(\*STDOUT, output => 1)], stderr => [PerlIO::get_layers(\*STDERR, output => 1)], ); # _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; # get layers from underlying glob of tied filehandles if we can # (this only works for things that work like Tie::StdHandle) $layers{stdout} = [PerlIO::get_layers(tied *STDOUT)] if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB'); $layers{stderr} = [PerlIO::get_layers(tied *STDERR)] if tied(*STDERR) && (reftype tied *STDERR eq 'GLOB'); # _debug( "# tied object corrected layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; # bypass scalar filehandles and tied handles # localize scalar STDIN to get a proxy to pick up FD0, then restore later to CT_ORIG_STDIN my %localize; $localize{stdin}++, local(*STDIN) if grep { $_ eq 'scalar' } @{$layers{stdin}}; $localize{stdout}++, local(*STDOUT) if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}}; $localize{stderr}++, local(*STDERR) if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}}; $localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0") if tied *STDIN && $] >= 5.008; $localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1") if $do_stdout && tied *STDOUT && $] >= 5.008; $localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2") if ($do_stderr || $do_merge) && tied *STDERR && $] >= 5.008; # _debug( "# localized $_\n" ) for keys %localize; # proxy any closed/localized handles so we don't use fds 0, 1 or 2 my %proxy_std = _proxy_std(); # _debug( "# proxy std: @{ [%proxy_std] }\n" ); # update layers after any proxying $layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout}; $layers{stderr} = [PerlIO::get_layers(\*STDERR, output => 1)] if $proxy_std{stderr}; # _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; # store old handles and setup handles for capture $stash->{old} = _copy_std(); $stash->{new} = { %{$stash->{old}} }; # default to originals for ( keys %do ) { $stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new); seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n"; $stash->{pos}{$_} = tell $stash->{capture}{$_}; # _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" ); _start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new} } _wait_for_tees( $stash ) if $do_tee; # finalize redirection $stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge; # _debug( "# redirecting in parent ...\n" ); _open_std( $stash->{new} ); # execute user provided code my ($exit_code, $inner_error, $outer_error, $orig_pid, @result); { $orig_pid = $$; local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN # _debug( "# finalizing layers ...\n" ); _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; _relayer(\*STDERR, $layers{stderr}) if $do_stderr; # _debug( "# running code $code ...\n" ); my $old_eval_err=$@; undef $@; eval { @result = $code->(); $inner_error = $@ }; $exit_code = $?; # save this for later $outer_error = $@; # save this for later STDOUT->flush if $do_stdout; STDERR->flush if $do_stderr; $@ = $old_eval_err; } # restore prior filehandles and shut down tees # _debug( "# restoring filehandles ...\n" ); _open_std( $stash->{old} ); _close( $_ ) for values %{$stash->{old}}; # don't leak fds # shouldn't need relayering originals, but see rt.perl.org #114404 _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; _relayer(\*STDERR, $layers{stderr}) if $do_stderr; _unproxy( %proxy_std ); # _debug( "# killing tee subprocesses ...\n" ) if $do_tee; _kill_tees( $stash ) if $do_tee; # return captured output, but shortcut in void context # unless we have to echo output to tied/scalar handles; my %got; if ( $orig_pid == $$ and ( defined wantarray or ($do_tee && keys %localize) ) ) { for ( keys %do ) { _relayer($stash->{capture}{$_}, $layers{$_}); $got{$_} = _slurp($_, $stash); # _debug("# slurped " . length($got{$_}) . " bytes from $_\n"); } print CT_ORIG_STDOUT $got{stdout} if $do_stdout && $do_tee && $localize{stdout}; print CT_ORIG_STDERR $got{stderr} if $do_stderr && $do_tee && $localize{stderr}; } $? = $exit_code; $@ = $inner_error if $inner_error; die $outer_error if $outer_error; # _debug( "# ending _capture_tee with (@_)...\n" ); return unless defined wantarray; my @return; push @return, $got{stdout} if $do_stdout; push @return, $got{stderr} if $do_stderr && ! $do_merge; push @return, @result; return wantarray ? @return : $return[0]; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs =head1 VERSION version 0.48 =head1 SYNOPSIS use Capture::Tiny ':all'; # capture from external command ($stdout, $stderr, $exit) = capture { system( $cmd, @args ); }; # capture from arbitrary code (Perl or external) ($stdout, $stderr, @result) = capture { # your code here }; # capture partial or merged output $stdout = capture_stdout { ... }; $stderr = capture_stderr { ... }; $merged = capture_merged { ... }; # tee output ($stdout, $stderr) = tee { # your code here }; $stdout = tee_stdout { ... }; $stderr = tee_stderr { ... }; $merged = tee_merged { ... }; =head1 DESCRIPTION Capture::Tiny provides a simple, portable way to capture almost anything sent to STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or from an external program. Optionally, output can be teed so that it is captured while being passed through to the original filehandles. Yes, it even works on Windows (usually). Stop guessing which of a dozen capturing modules to use in any particular situation and just use this one. =head1 USAGE The following functions are available. None are exported by default. =head2 capture ($stdout, $stderr, @result) = capture \&code; $stdout = capture \&code; The C function takes a code reference and returns what is sent to STDOUT and STDERR as well as any return values from the code reference. In scalar context, it returns only STDOUT. If no output was received for a filehandle, it returns an empty string for that filehandle. Regardless of calling context, all output is captured -- nothing is passed to the existing filehandles. It is prototyped to take a subroutine reference as an argument. Thus, it can be called in block form: ($stdout, $stderr) = capture { # your code here ... }; Note that the coderef is evaluated in list context. If you wish to force scalar context on the return value, you must use the C keyword. ($stdout, $stderr, $count) = capture { my @list = qw/one two three/; return scalar @list; # $count will be 3 }; Also note that within the coderef, the C<@_> variable will be empty. So don't use arguments from a surrounding subroutine without copying them to an array first: sub wont_work { my ($stdout, $stderr) = capture { do_stuff( @_ ) }; # WRONG ... } sub will_work { my @args = @_; my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT ... } Captures are normally done to an anonymous temporary filehandle. To capture via a named file (e.g. to externally monitor a long-running capture), provide custom filehandles as a trailing list of option pairs: my $out_fh = IO::File->new("out.txt", "w+"); my $err_fh = IO::File->new("out.txt", "w+"); capture { ... } stdout => $out_fh, stderr => $err_fh; The filehandles must be read/write and seekable. Modifying the files or filehandles during a capture operation will give unpredictable results. Existing IO layers on them may be changed by the capture. When called in void context, C saves memory and time by not reading back from the capture handles. =head2 capture_stdout ($stdout, @result) = capture_stdout \&code; $stdout = capture_stdout \&code; The C function works just like C except only STDOUT is captured. STDERR is not captured. =head2 capture_stderr ($stderr, @result) = capture_stderr \&code; $stderr = capture_stderr \&code; The C function works just like C except only STDERR is captured. STDOUT is not captured. =head2 capture_merged ($merged, @result) = capture_merged \&code; $merged = capture_merged \&code; The C function works just like C except STDOUT and STDERR are merged. (Technically, STDERR is redirected to the same capturing handle as STDOUT before executing the function.) Caution: STDOUT and STDERR output in the merged result are not guaranteed to be properly ordered due to buffering. =head2 tee ($stdout, $stderr, @result) = tee \&code; $stdout = tee \&code; The C function works just like C, except that output is captured as well as passed on to the original STDOUT and STDERR. When called in void context, C saves memory and time by not reading back from the capture handles, except when the original STDOUT OR STDERR were tied or opened to a scalar handle. =head2 tee_stdout ($stdout, @result) = tee_stdout \&code; $stdout = tee_stdout \&code; The C function works just like C except only STDOUT is teed. STDERR is not teed (output goes to STDERR as usual). =head2 tee_stderr ($stderr, @result) = tee_stderr \&code; $stderr = tee_stderr \&code; The C function works just like C except only STDERR is teed. STDOUT is not teed (output goes to STDOUT as usual). =head2 tee_merged ($merged, @result) = tee_merged \&code; $merged = tee_merged \&code; The C function works just like C except that output is captured as well as passed on to STDOUT. Caution: STDOUT and STDERR output in the merged result are not guaranteed to be properly ordered due to buffering. =head1 LIMITATIONS =head2 Portability Portability is a goal, not a guarantee. C requires fork, except on Windows where C is used instead. Not tested on any particularly esoteric platforms yet. See the L for test result by platform. =head2 PerlIO layers Capture::Tiny does its best to preserve PerlIO layers such as ':utf8' or ':crlf' when capturing (only for Perl 5.8.1+) . Layers should be applied to STDOUT or STDERR I the call to C or C. This may not work for tied filehandles (see below). =head2 Modifying filehandles before capturing Generally speaking, you should do little or no manipulation of the standard IO filehandles prior to using Capture::Tiny. In particular, closing, reopening, localizing or tying standard filehandles prior to capture may cause a variety of unexpected, undesirable and/or unreliable behaviors, as described below. Capture::Tiny does its best to compensate for these situations, but the results may not be what you desire. =head3 Closed filehandles Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously closed. However, since they will be reopened to capture or tee output, any code within the captured block that depends on finding them closed will, of course, not find them to be closed. If they started closed, Capture::Tiny will close them again when the capture block finishes. Note that this reopening will happen even for STDIN or a filehandle not being captured to ensure that the filehandle used for capture is not opened to file descriptor 0, as this causes problems on various platforms. Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles and also breaks tee() for undiagnosed reasons. So don't do that. =head3 Localized filehandles If code localizes any of Perl's standard filehandles before capturing, the capture will affect the localized filehandles and not the original ones. External system calls are not affected by localizing a filehandle in Perl and will continue to send output to the original filehandles (which will thus not be captured). =head3 Scalar filehandles If STDOUT or STDERR are reopened to scalar filehandles prior to the call to C or C, then Capture::Tiny will override the output filehandle for the duration of the C or C call and then, for C, send captured output to the output filehandle after the capture is complete. (Requires Perl 5.8) Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar reference, but note that external processes will not be able to read from such a handle. Capture::Tiny tries to ensure that external processes will read from the null device instead, but this is not guaranteed. =head3 Tied output filehandles If STDOUT or STDERR are tied prior to the call to C or C, then Capture::Tiny will attempt to override the tie for the duration of the C or C call and then send captured output to the tied filehandle after the capture is complete. (Requires Perl 5.8) Capture::Tiny may not succeed resending UTF-8 encoded data to a tied STDOUT or STDERR filehandle. Characters may appear as bytes. If the tied filehandle is based on L, then Capture::Tiny will attempt to determine appropriate layers like C<:utf8> from the underlying filehandle and do the right thing. =head3 Tied input filehandle Capture::Tiny attempts to preserve the semantics of tied STDIN, but this requires Perl 5.8 and is not entirely predictable. External processes will not be able to read from such a handle. Unless having STDIN tied is crucial, it may be safest to localize STDIN when capturing: my ($out, $err) = do { local *STDIN; capture { ... } }; =head2 Modifying filehandles during a capture Attempting to modify STDIN, STDOUT or STDERR I C or C is almost certainly going to cause problems. Don't do that. =head3 Forking inside a capture Forks aren't portable. The behavior of filehandles during a fork is even less so. If Capture::Tiny detects that a fork has occurred within a capture, it will shortcut in the child process and return empty strings for captures. Other problems may occur in the child or parent, as well. Forking in a capture block is not recommended. =head3 Using threads Filehandles are global. Mixing up I/O and captures in different threads without coordination is going to cause problems. Besides, threads are officially discouraged. =head3 Dropping privileges during a capture If you drop privileges during a capture, temporary files created to facilitate the capture may not be cleaned up afterwards. =head2 No support for Perl 5.8.0 It's just too buggy when it comes to layers and UTF-8. Perl 5.8.1 or later is recommended. =head2 Limited support for Perl 5.6 Perl 5.6 predates PerlIO. UTF-8 data may not be captured correctly. =head1 ENVIRONMENT =head2 PERL_CAPTURE_TINY_TIMEOUT Capture::Tiny uses subprocesses internally for C. By default, Capture::Tiny will timeout with an error if such subprocesses are not ready to receive data within 30 seconds (or whatever is the value of C<$Capture::Tiny::TIMEOUT>). An alternate timeout may be specified by setting the C environment variable. Setting it to zero will disable timeouts. B, this does not timeout the code reference being captured -- this only prevents Capture::Tiny itself from hanging your process waiting for its child processes to be ready to proceed. =head1 SEE ALSO This module was inspired by L, which provides similar functionality without the ability to tee output and with more complicated code and API. L does not handle layers or most of the unusual cases described in the L section and I no longer recommend it. There are many other CPAN modules that provide some sort of output capture, albeit with various limitations that make them appropriate only in particular circumstances. I'm probably missing some. The long list is provided to show why I felt Capture::Tiny was necessary. =over 4 =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =item * L =back =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at L. You will be notified automatically of any progress on your issue. =head2 Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. L git clone https://github.com/dagolden/Capture-Tiny.git =head1 AUTHOR David Golden =head1 CONTRIBUTORS =for stopwords Dagfinn Ilmari Mannsåker David E. Wheeler fecundf Graham Knop Peter Rabbitson =over 4 =item * Dagfinn Ilmari Mannsåker =item * David E. Wheeler =item * fecundf =item * Graham Knop =item * Peter Rabbitson =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2009 by David Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut Capture-Tiny-0.48/examples/tee.pl000644 000765 000024 00000000621 13267031477 017164 0ustar00davidstaff000000 000000 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' ); Capture-Tiny-0.48/examples/rt-58208.pl000644 000765 000024 00000000556 13267031477 017527 0ustar00davidstaff000000 000000 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; Capture-Tiny-0.48/xt/author/000755 000765 000024 00000000000 13267031477 016172 5ustar00davidstaff000000 000000 Capture-Tiny-0.48/xt/release/000755 000765 000024 00000000000 13267031477 016310 5ustar00davidstaff000000 000000 Capture-Tiny-0.48/xt/release/distmeta.t000644 000765 000024 00000000172 13267031477 020307 0ustar00davidstaff000000 000000 #!perl # This file was automatically generated by Dist::Zilla::Plugin::MetaTests. use Test::CPAN::Meta; meta_yaml_ok(); Capture-Tiny-0.48/xt/author/critic.t000644 000765 000024 00000000201 13267031477 017625 0ustar00davidstaff000000 000000 #!perl use strict; use warnings; use Test::Perl::Critic (-profile => "perlcritic.rc") x!! -e "perlcritic.rc"; all_critic_ok(); Capture-Tiny-0.48/xt/author/minimum-version.t000644 000765 000024 00000000130 13267031477 021507 0ustar00davidstaff000000 000000 #!perl use Test::More; use Test::MinimumVersion; all_minimum_version_ok( qq{5.010} ); Capture-Tiny-0.48/xt/author/test-version.t000644 000765 000024 00000000637 13267031477 021027 0ustar00davidstaff000000 000000 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; Capture-Tiny-0.48/xt/author/00-compile.t000644 000765 000024 00000002661 13267031477 020231 0ustar00davidstaff000000 000000 use 5.006; use strict; use warnings; # this test was generated with Dist::Zilla::Plugin::Test::Compile 2.058 use Test::More; plan tests => 2; my @module_files = ( 'Capture/Tiny.pm' ); # fake home for cpan-testers use File::Temp; local $ENV{HOME} = File::Temp::tempdir( CLEANUP => 1 ); my @switches = ( -d 'blib' ? '-Mblib' : '-Ilib', ); use File::Spec; use IPC::Open3; use IO::Handle; open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; my @warnings; for my $lib (@module_files) { # see L my $stderr = IO::Handle->new; diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} } $^X, @switches, '-e', "require q[$lib]")) if $ENV{PERL_COMPILE_TEST_DEBUG}; my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-e', "require q[$lib]"); binmode $stderr, ':crlf' if $^O eq 'MSWin32'; my @_warnings = <$stderr>; waitpid($pid, 0); is($?, 0, "$lib loaded ok"); shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ and not eval { +require blib; blib->VERSION('1.01') }; if (@_warnings) { warn @_warnings; push @warnings, @_warnings; } } is(scalar(@warnings), 0, 'no warnings found') or diag 'got warnings: ', ( Test::More->can('explain') ? Test::More::explain(\@warnings) : join("\n", '', @warnings) ); Capture-Tiny-0.48/xt/author/pod-syntax.t000644 000765 000024 00000000252 13267031477 020464 0ustar00davidstaff000000 000000 #!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(); Capture-Tiny-0.48/xt/author/portability.t000644 000765 000024 00000000322 13267031477 020716 0ustar00davidstaff000000 000000 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(); Capture-Tiny-0.48/xt/author/pod-spell.t000644 000765 000024 00000000640 13267031477 020256 0ustar00davidstaff000000 000000 use strict; use warnings; use Test::More; # generated by Dist::Zilla::Plugin::Test::PodSpelling 2.007005 use Test::Spelling 0.12; use Pod::Wordlist; add_stopwords(); all_pod_files_spelling_ok( qw( bin lib ) ); __DATA__ Capture Dagfinn David Golden Graham Ilmari Knop Mannsåker Peter Rabbitson Tiny UTF Wheeler dagolden david fecundf haarg ilmari lib not prototyped resending ribasushi seekable undiagnosed Capture-Tiny-0.48/xt/author/pod-coverage.t000644 000765 000024 00000000334 13267031477 020732 0ustar00davidstaff000000 000000 #!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' }); Capture-Tiny-0.48/t/19-relayering.t000644 000765 000024 00000004722 13267031477 017262 0ustar00davidstaff000000 000000 # 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: Capture-Tiny-0.48/t/24-all-badtied.t000644 000765 000024 00000002773 13267031477 017263 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/08-stdin-closed.t000644 000765 000024 00000003101 13267031477 017475 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/13-stdout-tied.t000644 000765 000024 00000002405 13267031477 017354 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/21-stderr-badtie.t000644 000765 000024 00000002357 13267031477 017645 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/20-stdout-badtie.t000644 000765 000024 00000002357 13267031477 017663 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/09-preserve-exit-code.t000644 000765 000024 00000001341 13267031477 020624 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/12-stdin-string.t000644 000765 000024 00000002574 13267031477 017542 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/02-capture.t000644 000765 000024 00000001376 13267031477 016556 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/22-stdin-badtie.t000644 000765 000024 00000002351 13267031477 017456 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/23-all-tied.t000644 000765 000024 00000003103 13267031477 016577 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/01-Capture-Tiny.t000644 000765 000024 00000001470 13267031477 017431 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/16-catch-errors.t000644 000765 000024 00000002273 13267031477 017511 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/00-report-prereqs.t000644 000765 000024 00000013426 13267031477 020102 0ustar00davidstaff000000 000000 #!perl use strict; use warnings; # This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.027 use Test::More tests => 1; use ExtUtils::MakeMaker; use File::Spec; # from $version::LAX my $lax_version_re = qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? | (?:\.[0-9]+) (?:_[0-9]+)? ) | (?: v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? | (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? ) )/x; # hide optional CPAN::Meta modules from prereq scanner # and check if they are available my $cpan_meta = "CPAN::Meta"; my $cpan_meta_pre = "CPAN::Meta::Prereqs"; my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic # Verify requirements? my $DO_VERIFY_PREREQS = 1; sub _max { my $max = shift; $max = ( $_ > $max ) ? $_ : $max for @_; return $max; } sub _merge_prereqs { my ($collector, $prereqs) = @_; # CPAN::Meta::Prereqs object if (ref $collector eq $cpan_meta_pre) { return $collector->with_merged_prereqs( CPAN::Meta::Prereqs->new( $prereqs ) ); } # Raw hashrefs for my $phase ( keys %$prereqs ) { for my $type ( keys %{ $prereqs->{$phase} } ) { for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; } } } return $collector; } my @include = qw( ); my @exclude = qw( ); # Add static prereqs to the included modules list my $static_prereqs = do './t/00-report-prereqs.dd'; # Merge all prereqs (either with ::Prereqs or a hashref) my $full_prereqs = _merge_prereqs( ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), $static_prereqs ); # Add dynamic prereqs to the included modules list (if we can) my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; my $cpan_meta_error; if ( $source && $HAS_CPAN_META && (my $meta = eval { CPAN::Meta->load_file($source) } ) ) { $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); } else { $cpan_meta_error = $@; # capture error from CPAN::Meta->load_file($source) $source = 'static metadata'; } my @full_reports; my @dep_errors; my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; # Add static includes into a fake section for my $mod (@include) { $req_hash->{other}{modules}{$mod} = 0; } for my $phase ( qw(configure build test runtime develop other) ) { next unless $req_hash->{$phase}; next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); for my $type ( qw(requires recommends suggests conflicts modules) ) { next unless $req_hash->{$phase}{$type}; my $title = ucfirst($phase).' '.ucfirst($type); my @reports = [qw/Module Want Have/]; for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { next if $mod eq 'perl'; next if grep { $_ eq $mod } @exclude; my $file = $mod; $file =~ s{::}{/}g; $file .= ".pm"; my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; my $want = $req_hash->{$phase}{$type}{$mod}; $want = "undef" unless defined $want; $want = "any" if !$want && $want == 0; my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; if ($prefix) { my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); $have = "undef" unless defined $have; push @reports, [$mod, $want, $have]; if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { if ( $have !~ /\A$lax_version_re\z/ ) { push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; } elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { push @dep_errors, "$mod version '$have' is not in required range '$want'"; } } } else { push @reports, [$mod, $want, "missing"]; if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { push @dep_errors, "$mod is not installed ($req_string)"; } } } if ( @reports ) { push @full_reports, "=== $title ===\n\n"; my $ml = _max( map { length $_->[0] } @reports ); my $wl = _max( map { length $_->[1] } @reports ); my $hl = _max( map { length $_->[2] } @reports ); if ($type eq 'modules') { splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; } else { splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; } push @full_reports, "\n"; } } } if ( @full_reports ) { diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; } if ( $cpan_meta_error || @dep_errors ) { diag "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n"; } if ( $cpan_meta_error ) { my ($orig_source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; diag "\nCPAN::Meta->load_file('$orig_source') failed with: $cpan_meta_error\n"; } if ( @dep_errors ) { diag join("\n", "\nThe following REQUIRED prerequisites were not satisfied:\n", @dep_errors, "\n" ); } pass; # vim: ts=4 sts=4 sw=4 et: Capture-Tiny-0.48/t/lib/000755 000765 000024 00000000000 13267031477 015246 5ustar00davidstaff000000 000000 Capture-Tiny-0.48/t/25-cap-fork.t000644 000765 000024 00000002370 13267031477 016615 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/11-stderr-string.t000644 000765 000024 00000002223 13267031477 017712 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/10-stdout-string.t000644 000765 000024 00000002224 13267031477 017731 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/06-stdout-closed.t000644 000765 000024 00000002003 13267031477 017674 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/07-stderr-closed.t000644 000765 000024 00000002002 13267031477 017655 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/00-report-prereqs.dd000644 000765 000024 00000005742 13267031477 020230 0ustar00davidstaff000000 000000 do { my $x = { 'configure' => { 'requires' => { 'ExtUtils::MakeMaker' => '6.17' } }, 'develop' => { 'requires' => { 'Dist::Zilla' => '5', 'Dist::Zilla::Plugin::OSPrereqs' => '0', 'Dist::Zilla::Plugin::Prereqs' => '0', 'Dist::Zilla::Plugin::ReleaseStatus::FromVersion' => '0', 'Dist::Zilla::Plugin::RemovePrereqs' => '0', 'Dist::Zilla::PluginBundle::DAGOLDEN' => '0.072', 'File::Spec' => '0', 'File::Temp' => '0', 'IO::Handle' => '0', 'IPC::Open3' => '0', 'Pod::Coverage::TrustPod' => '0', 'Pod::Wordlist' => '0', 'Software::License::Apache_2_0' => '0', 'Test::CPAN::Meta' => '0', 'Test::MinimumVersion' => '0', 'Test::More' => '0', 'Test::Perl::Critic' => '0', 'Test::Pod' => '1.41', 'Test::Pod::Coverage' => '1.08', 'Test::Portability::Files' => '0', 'Test::Spelling' => '0.12', 'Test::Version' => '1' } }, 'runtime' => { 'requires' => { 'Carp' => '0', 'Exporter' => '0', 'File::Spec' => '0', 'File::Temp' => '0', 'IO::Handle' => '0', 'Scalar::Util' => '0', 'perl' => '5.006', 'strict' => '0', 'warnings' => '0' } }, 'test' => { 'recommends' => { 'CPAN::Meta' => '2.120900' }, 'requires' => { 'ExtUtils::MakeMaker' => '0', 'File::Spec' => '0', 'IO::File' => '0', 'Test::More' => '0.62', 'lib' => '0' } } }; $x; }Capture-Tiny-0.48/t/18-custom-capture.t000644 000765 000024 00000011025 13267031477 020065 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/17-pass-results.t000644 000765 000024 00000005152 13267031477 017562 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/03-tee.t000644 000765 000024 00000001564 13267031477 015670 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/14-stderr-tied.t000644 000765 000024 00000002406 13267031477 017337 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/15-stdin-tied.t000644 000765 000024 00000002420 13267031477 017152 0ustar00davidstaff000000 000000 # 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; Capture-Tiny-0.48/t/lib/Cases.pm000644 000765 000024 00000021601 13267031477 016642 0ustar00davidstaff000000 000000 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; Capture-Tiny-0.48/t/lib/Utils.pm000644 000765 000024 00000002175 13267031477 016711 0ustar00davidstaff000000 000000 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; Capture-Tiny-0.48/t/lib/TieLC.pm000644 000765 000024 00000001460 13267031477 016545 0ustar00davidstaff000000 000000 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; Capture-Tiny-0.48/t/lib/TieEvil.pm000644 000765 000024 00000001332 13267031477 017144 0ustar00davidstaff000000 000000 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;