diff --git a/Changes b/Changes index 0672374..2b0ea97 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,35 @@ Revision history for Capture-Tiny + +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 diff --git a/MANIFEST b/MANIFEST index 26043d7..c204f55 100644 --- a/MANIFEST +++ b/MANIFEST @@ -5,6 +5,7 @@ META.yml Makefile.PL README +README.PATCHING Todo dist.ini examples/rt-58208.pl @@ -26,6 +27,8 @@ 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/lib/Cases.pm t/lib/TieLC.pm t/lib/Utils.pm @@ -33,3 +36,4 @@ xt/release/pod-coverage.t xt/release/pod-syntax.t xt/release/portability.t +xt/release/test-version.t diff --git a/META.json b/META.json index c527f00..369dcfe 100644 --- a/META.json +++ b/META.json @@ -4,7 +4,7 @@ "David Golden " ], "dynamic_config" : 1, - "generated_by" : "Dist::Zilla version 4.200005, CPAN::Meta::Converter version 2.110580", + "generated_by" : "Dist::Zilla version 4.300002, CPAN::Meta::Converter version 2.112580", "license" : [ "apache_2_0" ], @@ -27,7 +27,7 @@ "prereqs" : { "configure" : { "requires" : { - "ExtUtils::MakeMaker" : "6.31" + "ExtUtils::MakeMaker" : "6.30" } }, "runtime" : { @@ -37,13 +37,17 @@ "File::Spec" : 0, "File::Temp" : 0, "IO::Handle" : 0, - "perl" : "5.006" + "Scalar::Util" : 0, + "perl" : "5.006", + "strict" : 0, + "warnings" : 0 } }, "test" : { "requires" : { "Config" : 0, "File::Find" : 0, + "IO::File" : 0, "Test::More" : "0.62" } } @@ -51,7 +55,7 @@ "provides" : { "Capture::Tiny" : { "file" : "lib/Capture/Tiny.pm", - "version" : "0.11" + "version" : "0.13" } }, "release_status" : "stable", @@ -60,13 +64,13 @@ "mailto" : "bug-capture-tiny at rt.cpan.org", "web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=Capture-Tiny" }, - "homepage" : "http://github.com/dagolden/capture-tiny/tree", + "homepage" : "https://github.com/dagolden/capture-tiny", "repository" : { "type" : "git", - "url" : "git://github.com/dagolden/capture-tiny.git", - "web" : "http://github.com/dagolden/capture-tiny/tree" + "url" : "https://github.com/dagolden/capture-tiny.git", + "web" : "https://github.com/dagolden/capture-tiny" } }, - "version" : "0.11" + "version" : "0.13" } diff --git a/META.yml b/META.yml index dba53e5..970d926 100644 --- a/META.yml +++ b/META.yml @@ -5,11 +5,12 @@ build_requires: Config: 0 File::Find: 0 + IO::File: 0 Test::More: 0.62 configure_requires: - ExtUtils::MakeMaker: 6.31 + ExtUtils::MakeMaker: 6.30 dynamic_config: 1 -generated_by: 'Dist::Zilla version 4.200005, CPAN::Meta::Converter version 2.110580' +generated_by: 'Dist::Zilla version 4.300002, CPAN::Meta::Converter version 2.112580' license: apache meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html @@ -26,16 +27,19 @@ provides: Capture::Tiny: file: lib/Capture/Tiny.pm - version: 0.11 + version: 0.13 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: http://rt.cpan.org/Public/Dist/Display.html?Name=Capture-Tiny - homepage: http://github.com/dagolden/capture-tiny/tree - repository: git://github.com/dagolden/capture-tiny.git -version: 0.11 + homepage: https://github.com/dagolden/capture-tiny + repository: https://github.com/dagolden/capture-tiny.git +version: 0.13 diff --git a/Makefile.PL b/Makefile.PL index 11d0a51..a4045c7 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -2,37 +2,41 @@ use strict; use warnings; -BEGIN { require 5.006; } +use 5.006; -use ExtUtils::MakeMaker 6.31; +use ExtUtils::MakeMaker 6.30; my %WriteMakefileArgs = ( - 'ABSTRACT' => 'Capture STDOUT and STDERR from Perl, XS or external programs', - 'AUTHOR' => 'David Golden ', - 'BUILD_REQUIRES' => { - 'Config' => '0', - 'File::Find' => '0', - 'Test::More' => '0.62' + "ABSTRACT" => "Capture STDOUT and STDERR from Perl, XS or external programs", + "AUTHOR" => "David Golden ", + "BUILD_REQUIRES" => { + "Config" => 0, + "File::Find" => 0, + "IO::File" => 0, + "Test::More" => "0.62" }, - 'CONFIGURE_REQUIRES' => { - 'ExtUtils::MakeMaker' => '6.31' + "CONFIGURE_REQUIRES" => { + "ExtUtils::MakeMaker" => "6.30" }, - 'DISTNAME' => 'Capture-Tiny', - 'EXE_FILES' => [], - 'LICENSE' => 'apache', - 'NAME' => 'Capture::Tiny', - 'PREREQ_PM' => { - 'Carp' => '0', - 'Exporter' => '0', - 'File::Spec' => '0', - 'File::Temp' => '0', - 'IO::Handle' => '0' + "DISTNAME" => "Capture-Tiny", + "EXE_FILES" => [], + "LICENSE" => "apache", + "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 }, - 'VERSION' => '0.11', - 'test' => { - 'TESTS' => 't/*.t' + "VERSION" => "0.13", + "test" => { + "TESTS" => "t/*.t" } ); diff --git a/README b/README index d181d8a..6a5bc73 100644 --- a/README +++ b/README @@ -3,50 +3,49 @@ programs VERSION - version 0.11 + version 0.13 SYNOPSIS - use Capture::Tiny qw/capture tee capture_merged tee_merged/; + use Capture::Tiny ':all'; - ($stdout, $stderr) = capture { + ($stdout, $stderr, @result) = capture { # your code here }; + + $stdout = capture_stdout { ... }; + $stderr = capture_stderr { ... }; + $merged = capture_merged { ... }; ($stdout, $stderr) = tee { # your code here }; - $merged = capture_merged { - # your code here - }; - - $merged = tee_merged { - # your code here - }; + $stdout = tee_stdout { ... }; + $stderr = tee_stderr { ... }; + $merged = tee_merged { ... }; DESCRIPTION - Capture::Tiny provides a simple, portable way to capture anything sent - to STDOUT or STDERR, regardless of whether it comes from Perl, from XS - code or from an external program. Optionally, output can be teed so that - it is captured while being passed through to the original handles. Yes, - it even works on Windows. Stop guessing which of a dozen capturing - modules to use in any particular situation and just use this one. - - This module was heavily inspired by IO::CaptureOutput, which provides - similar functionality without the ability to tee output and with more - complicated code and API. + 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 handles. + 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) = capture \&code; + ($stdout, $stderr, @result) = capture \&code; $stdout = capture \&code; The "capture" function takes a code reference and returns what is sent - to STDOUT and STDERR. In scalar context, it returns only STDOUT. If no - output was received, returns an empty string. Regardless of context, all - output is captured -- nothing is passed to the existing handles. + 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 handle, it returns an empty string for that handle. + Regardless of calling context, all output is captured -- nothing is + passed to the existing handles. It is prototyped to take a subroutine reference as an argument. Thus, it can be called in block form: @@ -55,31 +54,79 @@ # 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 + }; + + Captures are normally done internally to an anonymous 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 and should be empty. + Modifying the files externally during a capture operation will give + unpredictable results. Existing IO layers on them may be changed by the + capture. + + 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 STDOUT - before executing the function.) If no output was received, returns an - empty string. As with "capture" it may be called in block form. + 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) = tee \&code; + ($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. As with - "capture" it may be called in block form. + captured as well as passed on to the original STDOUT and STDERR. + + 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. As with "capture" it - may be called in block form. + 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. @@ -93,17 +140,42 @@ PerlIO layers Capture::Tiny does it's best to preserve PerlIO layers such as ':utf8' or ':crlf' when capturing. Layers should be applied to STDOUT or STDERR - *before* the call to "capture" or "tee". - - Closed STDIN, STDOUT or STDERR + *before* the call to "capture" or "tee". This may not work for tied + handles (see below). + + Modifying filehandles before capturing + Generally speaking, you should do little or no manipulation of the + standard IO handles prior to using Capture::Tiny. In particular, + closing, reopening, localizing or tying standard handles prior to + capture may cause a variety of unexpected, undesireable 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 may 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 + 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 reclose them again when the capture block finishes. - Scalar filehandles and STDIN, STDOUT or STDERR + Note that this reopening will happen even for STDIN or a handle 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. + + Localized filehandles + + If code localizes any of Perl's standard handles before capturing, the + capture will affect the localized handles and not the original ones. + External system calls are not affected by localizing a handle in Perl + and will continue to send output to the original handles (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 handle for the duration of the "capture" or "tee" call and then send @@ -113,19 +185,23 @@ Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar reference. - Tied STDIN, STDOUT or STDERR + Tied handles + 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 handle after the capture is complete. (Requires Perl 5.8) - Capture::Tiny does not (yet) support resending utf8 encoded data to a - tied STDOUT or STDERR handle. Characters will appear as bytes. + Capture::Tiny may not succeed resending utf8 encoded data to a tied + STDOUT or STDERR handle. Characters may appear as bytes. If the tied + handle is based on Tie::StdHandle, then Capture::Tiny will attempt to + determine appropriate layers like ":utf8" from the underlying handle and + do the right thing. Capture::Tiny attempts to preserve the semantics of tied STDIN, but capturing or teeing when STDIN is tied is currently broken on Windows. - Modifiying STDIN, STDOUT or STDERR during a capture + Modifiying handles 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. @@ -150,7 +226,13 @@ to an existing test-file that illustrates the bug or desired feature. SEE ALSO - This is a selection of CPAN modules that provide some sort of output + 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. @@ -209,9 +291,9 @@ This is open source software. The code repository is available for public review and contribution under the terms of the license. - - - git clone git://github.com/dagolden/capture-tiny.git + + + git clone https://github.com/dagolden/capture-tiny.git AUTHOR David Golden diff --git a/README.PATCHING b/README.PATCHING new file mode 100644 index 0000000..3f58d99 --- /dev/null +++ b/README.PATCHING @@ -0,0 +1,42 @@ +README.PATCHING + +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 (e.g. Makefile.PL). + +However, you can run tests directly using the 'prove' tool: + + $ prove -l + $ prove -lv t/some_test_file.t + +For most distributions, 'prove' is entirely sufficent for you to test any +patches you have. + +Likewise, much of the documentation Pod is generated at release time. +Depending on the distribution, some documentation may be written in a Pod +dialect called WikiDoc. (See Pod::WikiDoc on CPAN.) 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. + +Dist::Zilla is a very powerful authoring tool, but requires a number of +author-specific plugins. If you would like to use it for contributing, +install it from CPAN, then run one of the following commands, depending on +your CPAN client: + + $ cpan `dzil authordeps` + $ dzil authordeps | cpanm + +Once installed, here are some dzil commands you might try: + + $ dzil build + $ dzil test + $ dzil xtest + +You can learn more about Dist::Zilla at http://dzil.org/ + diff --git a/dist.ini b/dist.ini index 78db962..dc3b36a 100644 --- a/dist.ini +++ b/dist.ini @@ -5,7 +5,6 @@ copyright_year = 2009 [@DAGOLDEN] -git_remote = github [OSPrereqs / MSWin32] Win32API::File = 0 diff --git a/examples/rt-58208.pl b/examples/rt-58208.pl index 089298a..dd5e164 100644 --- a/examples/rt-58208.pl +++ b/examples/rt-58208.pl @@ -1,12 +1,3 @@ -# -# This file is part of Capture-Tiny -# -# This software is Copyright (c) 2009 by David Golden. -# -# This is free software, licensed under: -# -# The Apache License, Version 2.0, January 2004 -# use Capture::Tiny qw[ capture ]; my ( $out, $err ) = diff --git a/examples/tee.pl b/examples/tee.pl index cc20cee..14839a9 100644 --- a/examples/tee.pl +++ b/examples/tee.pl @@ -1,12 +1,3 @@ -# -# This file is part of Capture-Tiny -# -# This software is Copyright (c) 2009 by David Golden. -# -# This is free software, licensed under: -# -# The Apache License, Version 2.0, January 2004 -# use strict; use warnings; diff --git a/lib/Capture/Tiny.pm b/lib/Capture/Tiny.pm index 905def5..23b810f 100644 --- a/lib/Capture/Tiny.pm +++ b/lib/Capture/Tiny.pm @@ -1,25 +1,15 @@ -# -# This file is part of Capture-Tiny -# -# This software is Copyright (c) 2009 by David Golden. -# -# This is free software, licensed under: -# -# The Apache License, Version 2.0, January 2004 -# use 5.006; use strict; use warnings; package Capture::Tiny; -BEGIN { - $Capture::Tiny::VERSION = '0.11'; -} # ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs +our $VERSION = '0.13'; # VERSION 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 $@; @@ -27,15 +17,41 @@ 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,0,1,0], # don't do STDERR since merging + tee => [1,1,0,1], + tee_stdout => [1,0,0,1], + tee_stderr => [0,1,0,1], + tee_merged => [1,0,1,1], # don't do STDERR since merging +); + +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 = qw/capture capture_merged tee tee_merged/; +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, ">&STDERR" if $DEBUG; +open $DEBUGFH, "> DEBUG" if $DEBUG; *_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0}; @@ -59,10 +75,10 @@ sub _relayer { my ($fh, $layers) = @_; - _debug("# requested layers (@{$layers}) to $fh\n"); + _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n"); my %seen = ( unix => 1, perlio => 1 ); # filter these out my @unique = grep { !$seen{$_}++ } @$layers; - _debug("# applying unique layers (@unique) to $fh\n"); + _debug("# applying unique layers (@unique) to @{[fileno $fh]}\n"); binmode($fh, join(":", ":raw", @unique)); } @@ -223,7 +239,12 @@ $stash->{pid}{$which} = $pid } -sub _files_exist { -f $_ || return 0 for @_; return 1 } +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) = @_; @@ -252,7 +273,9 @@ } sub _slurp { - seek $_[0],0,0; local $/; return scalar readline $_[0]; + my ($name, $fh) = @_; + _debug( "# slurping captured $name with layers: @{[PerlIO::get_layers($fh)]}\n"); + seek $fh,0,0; local $/; return scalar readline $fh } #--------------------------------------------------------------------------# @@ -261,7 +284,15 @@ sub _capture_tee { _debug( "# starting _capture_tee with (@_)...\n" ); - my ($tee_stdout, $tee_stderr, $merge, $code) = @_; + my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_; + Carp::confess("Custom capture options must be given as key/value pairs\n") + unless @opts % 2 == 0; + my $stash = { capture => { @opts } }; + for my $n ( keys %{$stash->{capture}} ) { + my $fh = $stash->{capture}{$n}; + Carp::confess "Custom handle for $n 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; @@ -273,86 +304,91 @@ stderr => [PerlIO::get_layers(\*STDERR)], ); _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 my %localize; - $localize{stdin}++, local(*STDIN) if grep { $_ eq 'scalar' } @{$layers{stdin}}; - $localize{stdout}++, local(*STDOUT) if grep { $_ eq 'scalar' } @{$layers{stdout}}; - $localize{stderr}++, local(*STDERR) if grep { $_ eq 'scalar' } @{$layers{stderr}}; - $localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1") if tied *STDOUT && $] >= 5.008; - $localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2") if tied *STDERR && $] >= 5.008; + $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{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 is @{ [%proxy_std] }\n" ); - my $stash = { old => _copy_std() }; + _debug( "# proxy std: @{ [%proxy_std] }\n" ); # update layers after any proxying - %layers = ( - stdin => [PerlIO::get_layers(\*STDIN) ], - stdout => [PerlIO::get_layers(\*STDOUT)], - stderr => [PerlIO::get_layers(\*STDERR)], - ); + $layers{stdin} = [PerlIO::get_layers(\*STDIN)] if $proxy_std{stdin}; + $layers{stdout} = [PerlIO::get_layers(\*STDOUT)] if $proxy_std{stdout}; + $layers{stderr} = [PerlIO::get_layers(\*STDERR)] 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 + $stash->{new}{stdout} = ($stash->{capture}{stdout} ||= File::Temp->new) if $do_stdout; + $stash->{new}{stderr} = ($stash->{capture}{stderr} ||= File::Temp->new) if $do_stderr; + _debug("# will capture stdout on " . fileno($stash->{capture}{stdout})."\n" ) if $do_stdout; + _debug("# will capture stderr on " . fileno($stash->{capture}{stderr})."\n" ) if $do_stderr; # get handles for capture and apply existing IO layers - $stash->{new}{$_} = $stash->{capture}{$_} = File::Temp->new for qw/stdout stderr/; - _debug("# will capture $_ on " .fileno($stash->{capture}{$_})."\n" ) for qw/stdout stderr/; # tees may change $stash->{new} - _start_tee( stdout => $stash ) if $tee_stdout; - _start_tee( stderr => $stash ) if $tee_stderr; - _wait_for_tees( $stash ) if $tee_stdout || $tee_stderr; + _start_tee( stdout => $stash ) if $do_stdout && $do_tee; + _start_tee( stderr => $stash ) if $do_stderr && $do_tee; + _wait_for_tees( $stash ) if $do_tee; # finalize redirection - $stash->{new}{stderr} = $stash->{new}{stdout} if $merge; - $stash->{new}{stdin} = $stash->{old}{stdin}; + $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); + my ($exit_code, $inner_error, $outer_error, @result); { local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN - local *STDERR = *STDOUT if $merge; # minimize buffer mixups during $code + local *STDERR = *STDOUT if $do_merge; # minimize buffer mixups during $code _debug( "# finalizing layers ...\n" ); - _relayer(\*STDOUT, $layers{stdout}); - _relayer(\*STDERR, $layers{stderr}) unless $merge; + _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; + _relayer(\*STDERR, $layers{stderr}) if $do_stderr; _debug( "# running code $code ...\n" ); local $@; - eval { $code->(); $inner_error = $@ }; + eval { @result = $code->(); $inner_error = $@ }; $exit_code = $?; # save this for later $outer_error = $@; # save this for later } # restore prior filehandles and shut down tees - _debug( "# restoring ...\n" ); + _debug( "# restoring filehandles ...\n" ); _open_std( $stash->{old} ); _close( $_ ) for values %{$stash->{old}}; # don't leak fds _unproxy( %proxy_std ); - _kill_tees( $stash ) if $tee_stdout || $tee_stderr; + _debug( "# killing tee subprocesses ...\n" ) if $do_tee; + _kill_tees( $stash ) if $do_tee; # return captured output - _relayer($stash->{capture}{stdout}, $layers{stdout}); - _relayer($stash->{capture}{stderr}, $layers{stderr}) unless $merge; - _debug( "# slurping captured $_ with layers: @{[PerlIO::get_layers($stash->{capture}{$_})]}\n") for qw/stdout stderr/; - my $got_out = _slurp($stash->{capture}{stdout}); - my $got_err = $merge ? q() : _slurp($stash->{capture}{stderr}); - print CT_ORIG_STDOUT $got_out if $localize{stdout} && $tee_stdout; - print CT_ORIG_STDERR $got_err if !$merge && $localize{stderr} && $tee_stdout; + _relayer($stash->{capture}{stdout}, $layers{stdout}) if $do_stdout; + _relayer($stash->{capture}{stderr}, $layers{stderr}) if $do_stderr; + my $got_out = $do_stdout ? _slurp('stdout' => $stash->{capture}{stdout}) : q(); + my $got_err = $do_stderr ? _slurp('stderr' => $stash->{capture}{stderr}) : q(); + _debug("# slurped " . length($got_out) . " bytes from stdout\n"); + _debug("# slurped " . length($got_err) . " bytes from stderr\n"); + print CT_ORIG_STDOUT $got_out + if $do_stdout && $do_tee && $localize{stdout}; + print CT_ORIG_STDERR $got_err + 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 $got_out if $merge; - return wantarray ? ($got_out, $got_err) : $got_out; -} - -#--------------------------------------------------------------------------# -# create API subroutines from [tee STDOUT flag, tee STDERR, merge flag] -#--------------------------------------------------------------------------# - -my %api = ( - capture => [0,0,0], - capture_merged => [0,0,1], - tee => [1,1,0], - tee_merged => [1,0,1], # don't tee STDOUT since merging -); - -for my $sub ( keys %api ) { - my $args = join q{, }, @{$api{$sub}}; - eval "sub $sub(&) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic + my @return; + push @return, $got_out if $do_stdout; + push @return, $got_err if $do_stderr; + push @return, @result; + return wantarray ? @return : $return[0]; } 1; @@ -367,40 +403,36 @@ =head1 VERSION -version 0.11 +version 0.13 =head1 SYNOPSIS - use Capture::Tiny qw/capture tee capture_merged tee_merged/; + use Capture::Tiny ':all'; - ($stdout, $stderr) = capture { + ($stdout, $stderr, @result) = capture { # your code here }; + + $stdout = capture_stdout { ... }; + $stderr = capture_stderr { ... }; + $merged = capture_merged { ... }; ($stdout, $stderr) = tee { # your code here }; - $merged = capture_merged { - # your code here - }; - - $merged = tee_merged { - # your code here - }; + $stdout = tee_stdout { ... }; + $stderr = tee_stderr { ... }; + $merged = tee_merged { ... }; =head1 DESCRIPTION -Capture::Tiny provides a simple, portable way to capture anything sent to -STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or +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 handles. Yes, it even -works on Windows. Stop guessing which of a dozen capturing modules to use in -any particular situation and just use this one. - -This module was heavily inspired by L, which provides -similar functionality without the ability to tee output and with more -complicated code and API. +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 @@ -408,13 +440,14 @@ =head2 capture - ($stdout, $stderr) = capture \&code; + ($stdout, $stderr, @result) = capture \&code; $stdout = capture \&code; The C<<< capture >>> function takes a code reference and returns what is sent to -STDOUT and STDERR. In scalar context, it returns only STDOUT. If no output -was received, returns an empty string. Regardless of context, all output is -captured -- nothing is passed to the existing handles. +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 +handle, it returns an empty string for that handle. Regardless of calling +context, all output is captured -- nothing is passed to the existing handles. It is prototyped to take a subroutine reference as an argument. Thus, it can be called in block form: @@ -423,34 +456,85 @@ # 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<<< scalar >>> keyword. + + ($stdout, $stderr, $count) = capture { + my @list = qw/one two three/; + return scalar @list; # $count will be 3 + }; + +Captures are normally done internally to an anonymous 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 readEwrite and seekable and should be empty. Modifying +the files externally during a capture operation will give unpredictable +results. Existing IO layers on them may be changed by the capture. + +=head2 capture_stdout + + ($stdout, @result) = capture_stdout \&code; + $stdout = capture_stdout \&code; + +The C<<< capture_stdout >>> function works just like C<<< capture >>> except only +STDOUT is captured. STDERR is not captured. + +=head2 capture_stderr + + ($stderr, @result) = capture_stderr \&code; + $stderr = capture_stderr \&code; + +The C<<< capture_stderr >>> function works just like C<<< capture >>> except only +STDERR is captured. STDOUT is not captured. + =head2 capture_merged + ($merged, @result) = capture_merged \&code; $merged = capture_merged \&code; The C<<< capture_merged >>> function works just like C<<< capture >>> except STDOUT and STDERR are merged. (Technically, STDERR is redirected to STDOUT before -executing the function.) If no output was received, returns an empty string. -As with C<<< capture >>> it may be called in block form. +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) = tee \&code; + ($stdout, $stderr, @result) = tee \&code; $stdout = tee \&code; The C<<< tee >>> function works just like C<<< capture >>>, except that output is captured -as well as passed on to the original STDOUT and STDERR. As with C<<< capture >>> it -may be called in block form. +as well as passed on to the original STDOUT and STDERR. + +=head2 tee_stdout + + ($stdout, @result) = tee_stdout \&code; + $stdout = tee_stdout \&code; + +The C<<< tee_stdout >>> function works just like C<<< tee >>> 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<<< tee_stderr >>> function works just like C<<< tee >>> 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<<< tee_merged >>> function works just like C<<< capture_merged >>> except that output -is captured as well as passed on to STDOUT. As with C<<< capture >>> it may be called -in block form. +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. @@ -467,17 +551,37 @@ Capture::Tiny does it's best to preserve PerlIO layers such as ':utf8' or ':crlf' when capturing. Layers should be applied to STDOUT or STDERR I -the call to C<<< capture >>> or C<<< tee >>>. - -=head2 Closed STDIN, STDOUT or STDERR +the call to C<<< capture >>> or C<<< tee >>>. This may not work for tied handles (see below). + +=head2 Modifying filehandles before capturing + +Generally speaking, you should do little or no manipulation of the standard IO +handles prior to using Capture::Tiny. In particular, closing, reopening, +localizing or tying standard handles prior to capture may cause a variety of +unexpected, undesireable andEor unreliable behaviors, as described below. +Capture::Tiny does its best to compensate for these situations, but the +results may not be what you desire. + +B Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously -closed. However, since they may 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 reclose -them again when the capture block finishes. - -=head2 Scalar filehandles and STDIN, STDOUT or STDERR +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 +reclose them again when the capture block finishes. + +Note that this reopening will happen even for STDIN or a handle 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. + +B + +If code localizes any of Perl's standard handles before capturing, the capture +will affect the localized handles and not the original ones. External system +calls are not affected by localizing a handle in Perl and will continue +to send output to the original handles (which will thus not be captured). + +B If STDOUT or STDERR are reopened to scalar filehandles prior to the call to C<<< capture >>> or C<<< tee >>>, then Capture::Tiny will override the output handle for the @@ -487,20 +591,23 @@ Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar reference. -=head2 Tied STDIN, STDOUT or STDERR +B If STDOUT or STDERR are tied prior to the call to C<<< capture >>> or C<<< tee >>>, then Capture::Tiny will attempt to override the tie for the duration of the C<<< capture >>> or C<<< tee >>> call and then send captured output to the tied handle after the capture is complete. (Requires Perl 5.8) -Capture::Tiny does not (yet) support resending utf8 encoded data to a tied -STDOUT or STDERR handle. Characters will appear as bytes. +Capture::Tiny may not succeed resending utf8 encoded data to a tied +STDOUT or STDERR handle. Characters may appear as bytes. If the tied handle +is based on L, then Capture::Tiny will attempt to determine +appropriate layers like C<<< :utf8 >>> from the underlying handle and do the right +thing. Capture::Tiny attempts to preserve the semantics of tied STDIN, but capturing or teeing when STDIN is tied is currently broken on Windows. -=head2 Modifiying STDIN, STDOUT or STDERR during a capture +=head2 Modifiying handles during a capture Attempting to modify STDIN, STDOUT or STDERR I C<<< capture >>> or C<<< tee >>> is almost certainly going to cause problems. Don't do that. @@ -530,7 +637,13 @@ =head1 SEE ALSO -This is a selection of CPAN modules that provide some sort of output capture, +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. @@ -638,9 +751,9 @@ This is open source software. The code repository is available for public review and contribution under the terms of the license. -L - - git clone git://github.com/dagolden/capture-tiny.git +L + + git clone https://github.com/dagolden/capture-tiny.git =head1 AUTHOR diff --git a/t/00-compile.t b/t/00-compile.t index f66262f..6ce3690 100644 --- a/t/00-compile.t +++ b/t/00-compile.t @@ -1,13 +1,4 @@ #!perl -# -# This file is part of Capture-Tiny -# -# This software is Copyright (c) 2009 by David Golden. -# -# This is free software, licensed under: -# -# The Apache License, Version 2.0, January 2004 -# use strict; use warnings; @@ -33,7 +24,18 @@ 'lib', ); -my @scripts = glob "bin/*"; +my @scripts; +if ( -d 'bin' ) { + find( + sub { + return unless -f; + my $found = $File::Find::name; + # nothing to skip + push @scripts, $found; + }, + 'bin', + ); +} my $plan = scalar(@modules) + scalar(@scripts); $plan ? (plan tests => $plan) : (plan skip_all => "no tests to run"); diff --git a/t/01-Capture-Tiny.t b/t/01-Capture-Tiny.t index db4f9d2..eb0cd5a 100644 --- a/t/01-Capture-Tiny.t +++ b/t/01-Capture-Tiny.t @@ -11,8 +11,12 @@ my @api = qw( capture + capture_stdout + capture_stderr capture_merged tee + tee_stdout + tee_stderr tee_merged ); diff --git a/t/02-capture.t b/t/02-capture.t index 39f1bce..a70e3b1 100644 --- a/t/02-capture.t +++ b/t/02-capture.t @@ -20,6 +20,8 @@ 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" ); diff --git a/t/03-tee.t b/t/03-tee.t index 1fd99e9..958c604 100644 --- a/t/03-tee.t +++ b/t/03-tee.t @@ -27,6 +27,8 @@ 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" ); diff --git a/t/06-stdout-closed.t b/t/06-stdout-closed.t index 92b4f6a..5b98e56 100644 --- a/t/06-stdout-closed.t +++ b/t/06-stdout-closed.t @@ -27,6 +27,8 @@ run_test($_) for qw( capture capture_scalar + capture_stdout + capture_stderr capture_merged ); @@ -34,6 +36,8 @@ run_test($_) for qw( tee tee_scalar + tee_stdout + tee_stderr tee_merged ); } diff --git a/t/07-stderr-closed.t b/t/07-stderr-closed.t index b50ade9..1d814a3 100644 --- a/t/07-stderr-closed.t +++ b/t/07-stderr-closed.t @@ -27,6 +27,8 @@ run_test($_) for qw( capture capture_scalar + capture_stdout + capture_stderr capture_merged ); @@ -34,6 +36,8 @@ run_test($_) for qw( tee tee_scalar + tee_stdout + tee_stderr tee_merged ); } diff --git a/t/08-stdin-closed.t b/t/08-stdin-closed.t index 8c8f654..81fd6dc 100644 --- a/t/08-stdin-closed.t +++ b/t/08-stdin-closed.t @@ -27,6 +27,8 @@ run_test($_) for qw( capture capture_scalar + capture_stdout + capture_stderr capture_merged ); @@ -34,6 +36,8 @@ run_test($_) for qw( tee tee_scalar + tee_stdout + tee_stderr tee_merged ); } diff --git a/t/10-stdout-string.t b/t/10-stdout-string.t index 24b100b..93f9d80 100644 --- a/t/10-stdout-string.t +++ b/t/10-stdout-string.t @@ -31,6 +31,8 @@ run_test($_) for qw( capture capture_scalar + capture_stdout + capture_stderr capture_merged ); @@ -38,6 +40,8 @@ run_test($_) for qw( tee tee_scalar + tee_stdout + tee_stderr tee_merged ); } diff --git a/t/11-stderr-string.t b/t/11-stderr-string.t index ad38410..916d43d 100644 --- a/t/11-stderr-string.t +++ b/t/11-stderr-string.t @@ -31,6 +31,8 @@ run_test($_) for qw( capture capture_scalar + capture_stdout + capture_stderr capture_merged ); @@ -38,6 +40,8 @@ run_test($_) for qw( tee tee_scalar + tee_stdout + tee_stderr tee_merged ); } diff --git a/t/12-stdin-string.t b/t/12-stdin-string.t index adeeb66..1412fe2 100644 --- a/t/12-stdin-string.t +++ b/t/12-stdin-string.t @@ -37,6 +37,8 @@ run_test($_) for qw( capture capture_scalar + capture_stdout + capture_stderr capture_merged ); @@ -44,6 +46,8 @@ run_test($_) for qw( tee tee_scalar + tee_stdout + tee_stderr tee_merged ); } diff --git a/t/13-stdout-tied.t b/t/13-stdout-tied.t index 0ead54b..b52f2f6 100644 --- a/t/13-stdout-tied.t +++ b/t/13-stdout-tied.t @@ -1,7 +1,7 @@ # 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 +# 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; @@ -27,20 +27,24 @@ save_std(qw/stdout/); tie *STDOUT, 'TieLC', ">&=STDOUT"; my $orig_tie = tied *STDOUT; -ok( $orig_tie, "STDOUT is tied" ); +ok( $orig_tie, "STDOUT is tied" ); my $fd = next_fd; -run_test($_, 'unicode') for qw( +run_test($_) for qw( capture capture_scalar + capture_stdout + capture_stderr capture_merged ); if ( ! $no_fork ) { - run_test($_, 'unicode') for qw( + run_test($_) for qw( tee tee_scalar + tee_stdout + tee_stderr tee_merged ); } diff --git a/t/14-stderr-tied.t b/t/14-stderr-tied.t index cad79f4..567bc0b 100644 --- a/t/14-stderr-tied.t +++ b/t/14-stderr-tied.t @@ -31,16 +31,20 @@ my $fd = next_fd; -run_test($_, 'unicode') for qw( +run_test($_) for qw( capture capture_scalar + capture_stdout + capture_stderr capture_merged ); if ( ! $no_fork ) { - run_test($_, 'unicode') for qw( + run_test($_) for qw( tee tee_scalar + tee_stdout + tee_stderr tee_merged ); } diff --git a/t/15-stdin-tied.t b/t/15-stdin-tied.t index b0a2607..704ba04 100644 --- a/t/15-stdin-tied.t +++ b/t/15-stdin-tied.t @@ -36,6 +36,8 @@ run_test($_) for qw( capture capture_scalar + capture_stdout + capture_stderr capture_merged ); @@ -43,6 +45,8 @@ run_test($_) for qw( tee tee_scalar + tee_stdout + tee_stderr tee_merged ); } diff --git a/t/17-pass-results.t b/t/17-pass-results.t new file mode 100644 index 0000000..320259d --- /dev/null +++ b/t/17-pass-results.t @@ -0,0 +1,87 @@ +# Copyright (c) 2009 by David Golden. All rights reserved. +# Licensed under Apache License, Version 2.0 (the "License"). +# You may not use this file except in compliance with the License. +# A copy of the License was distributed with this file or you may obtain a +# copy of the License from http://www.apache.org/licenses/LICENSE-2.0 + +use strict; +use warnings; +use Test::More; +use lib 't/lib'; +use IO::Handle; +use Utils qw/next_fd sig_num/; +use Capture::Tiny ':all'; +use Config; + +plan tests => 12; + +local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # no timeouts + +my $builder = Test::More->builder; +binmode($builder->failure_output, ':utf8') if $] >= 5.008; + +my $fd = next_fd; +my ($out, $err, $res, @res); + +#--------------------------------------------------------------------------# +# capture to array +#--------------------------------------------------------------------------# + +($out, $err, @res) = capture { + print STDOUT "foo\n"; + print STDERR "bar\n"; + return qw/one two three/; +}; + +is( $out, "foo\n", "capture -> STDOUT captured" ); +is( $err, "bar\n", "capture -> STDERR captured" ); +is_deeply( \@res, [qw/one two three/], "return values -> array" ); + +#--------------------------------------------------------------------------# +# capture to scalar +#--------------------------------------------------------------------------# + +($out, $err, $res) = capture { + print STDOUT "baz\n"; + print STDERR "bam\n"; + return qw/one two three/; +}; + +is( $out, "baz\n", "capture -> STDOUT captured" ); +is( $err, "bam\n", "capture -> STDERR captured" ); +is( $res, "one", "return value -> scalar" ); + +#--------------------------------------------------------------------------# +# capture_stdout to array +#--------------------------------------------------------------------------# + +($out, @res) = capture_stdout { + print STDOUT "foo\n"; + return qw/one two three/; +}; + +is( $out, "foo\n", "capture_stdout -> STDOUT captured" ); +is_deeply( \@res, [qw/one two three/], "return values -> array" ); + +#--------------------------------------------------------------------------# +# capture_merged to array +#--------------------------------------------------------------------------# + +($out, $res) = capture_merged { + print STDOUT "baz\n"; + print STDERR "bam\n"; + return qw/one two three/; +}; + +like( $out, qr/baz/, "capture_merged -> STDOUT captured" ); +like( $out, qr/bam/, "capture_merged -> STDERR captured" ); +is( $res, "one", "return value -> scalar" ); + +#--------------------------------------------------------------------------# +# finish +#--------------------------------------------------------------------------# + +is( next_fd, $fd, "no file descriptors leaked" ); + +exit 0; + diff --git a/t/18-custom-capture.t b/t/18-custom-capture.t new file mode 100644 index 0000000..7035a4a --- /dev/null +++ b/t/18-custom-capture.t @@ -0,0 +1,94 @@ +# 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 => 9; + +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 +#--------------------------------------------------------------------------# + +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; + +#--------------------------------------------------------------------------# + +$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; + +#--------------------------------------------------------------------------# +# finish +#--------------------------------------------------------------------------# + +close ARGV; # opened by reading from <> +is( next_fd, $fd, "no file descriptors leaked" ); + +exit 0; + diff --git a/t/lib/Cases.pm b/t/lib/Cases.pm index 7706ea2..9c0a925 100644 --- a/t/lib/Cases.pm +++ b/t/lib/Cases.pm @@ -1,12 +1,3 @@ -# -# This file is part of Capture-Tiny -# -# This software is Copyright (c) 2009 by David Golden. -# -# This is free software, licensed under: -# -# The Apache License, Version 2.0, January 2004 -# package Cases; use strict; use warnings; @@ -19,8 +10,8 @@ run_test ); -my $have_diff = eval { - require Test::Differences; +my $have_diff = eval { + require Test::Differences; Test::Differences->import; $Test::Differences::VERSION < 0.60; # 0.60+ is causing strange failures }; @@ -40,17 +31,20 @@ my $t = shift; return unless $t eq 'unicode'; my %seen; - my @orig_layers = grep {$_ ne 'unix' and $_ ne 'perlio' and $seen{$_}++} PerlIO::get_layers(\*STDOUT); - binmode(STDOUT, ":utf8") if fileno(STDOUT); - binmode(STDERR, ":utf8") if fileno(STDERR); + 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)) if fileno(STDOUT); - binmode(STDERR, join( ":", "", "raw", @orig_layers)) if fileno(STDERR); + binmode(STDOUT, join( ":", "", "raw", @{$orig_layers[0]})) if fileno(STDOUT); + binmode(STDERR, join( ":", "", "raw", @{$orig_layers[1]})) if fileno(STDERR); } #--------------------------------------------------------------------------# @@ -113,6 +107,38 @@ _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 { @@ -156,6 +182,38 @@ _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 => { @@ -195,7 +253,7 @@ for my $c ( keys %channels ) { for my $t ( keys %texts ) { my @orig_layers = _set_utf8($t); - local $TODO = "not yet supported" + 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); diff --git a/t/lib/TieLC.pm b/t/lib/TieLC.pm index 314aedf..1dd384e 100644 --- a/t/lib/TieLC.pm +++ b/t/lib/TieLC.pm @@ -1,12 +1,3 @@ -# -# This file is part of Capture-Tiny -# -# This software is Copyright (c) 2009 by David Golden. -# -# This is free software, licensed under: -# -# The Apache License, Version 2.0, January 2004 -# package TieLC; sub TIEHANDLE diff --git a/t/lib/Utils.pm b/t/lib/Utils.pm index ac06274..6ea4d88 100644 --- a/t/lib/Utils.pm +++ b/t/lib/Utils.pm @@ -1,12 +1,3 @@ -# -# This file is part of Capture-Tiny -# -# This software is Copyright (c) 2009 by David Golden. -# -# This is free software, licensed under: -# -# The Apache License, Version 2.0, January 2004 -# package Utils; use strict; use warnings; diff --git a/xt/release/distmeta.t b/xt/release/distmeta.t index 8fa9a00..b46c7fc 100644 --- a/xt/release/distmeta.t +++ b/xt/release/distmeta.t @@ -1,13 +1,4 @@ #!perl -# -# This file is part of Capture-Tiny -# -# This software is Copyright (c) 2009 by David Golden. -# -# This is free software, licensed under: -# -# The Apache License, Version 2.0, January 2004 -# use Test::More; diff --git a/xt/release/pod-coverage.t b/xt/release/pod-coverage.t index 0106f98..b52218b 100644 --- a/xt/release/pod-coverage.t +++ b/xt/release/pod-coverage.t @@ -1,13 +1,4 @@ #!perl -# -# This file is part of Capture-Tiny -# -# This software is Copyright (c) 2009 by David Golden. -# -# This is free software, licensed under: -# -# The Apache License, Version 2.0, January 2004 -# use Test::More; diff --git a/xt/release/pod-syntax.t b/xt/release/pod-syntax.t index bc1aab6..8a22900 100644 --- a/xt/release/pod-syntax.t +++ b/xt/release/pod-syntax.t @@ -1,13 +1,4 @@ #!perl -# -# This file is part of Capture-Tiny -# -# This software is Copyright (c) 2009 by David Golden. -# -# This is free software, licensed under: -# -# The Apache License, Version 2.0, January 2004 -# use Test::More; eval "use Test::Pod 1.41"; diff --git a/xt/release/portability.t b/xt/release/portability.t index 48680b2..e57e66e 100644 --- a/xt/release/portability.t +++ b/xt/release/portability.t @@ -1,13 +1,4 @@ #!perl -# -# This file is part of Capture-Tiny -# -# This software is Copyright (c) 2009 by David Golden. -# -# This is free software, licensed under: -# -# The Apache License, Version 2.0, January 2004 -# use Test::More; diff --git a/xt/release/test-version.t b/xt/release/test-version.t new file mode 100644 index 0000000..b5b6f14 --- /dev/null +++ b/xt/release/test-version.t @@ -0,0 +1,12 @@ +#!/usr/bin/perl +use 5.006; +use strict; +use warnings; +use Test::More; + +eval "use Test::Version 0.04"; +plan skip_all => "Test::Version 0.04 required for testing versions" + if $@; + +version_all_ok(); +done_testing;