├── .gitignore ├── .mailmap ├── .travis.yml ├── CONTRIBUTING.mkdn ├── Changes ├── Makefile.PL ├── README.mkdn ├── Todo ├── dist.ini ├── examples ├── rt-58208.pl └── tee.pl ├── lib └── Capture │ └── Tiny.pm ├── perlcritic.rc └── t ├── 01-Capture-Tiny.t ├── 02-capture.t ├── 03-tee.t ├── 06-stdout-closed.t ├── 07-stderr-closed.t ├── 08-stdin-closed.t ├── 09-preserve-exit-code.t ├── 10-stdout-string.t ├── 11-stderr-string.t ├── 12-stdin-string.t ├── 13-stdout-tied.t ├── 14-stderr-tied.t ├── 15-stdin-tied.t ├── 16-catch-errors.t ├── 17-pass-results.t ├── 18-custom-capture.t ├── 19-relayering.t ├── 20-stdout-badtie.t ├── 21-stderr-badtie.t ├── 22-stdin-badtie.t ├── 23-all-tied.t ├── 24-all-badtied.t ├── 25-cap-fork.t └── lib ├── Cases.pm ├── TieEvil.pm ├── TieLC.pm └── Utils.pm /.gitignore: -------------------------------------------------------------------------------- 1 | Build.bat 2 | Build 3 | _build/ 4 | blib/ 5 | *.tmp 6 | *.bak 7 | cover_db/ 8 | MYMETA.yml 9 | .build 10 | /Capture-Tiny-* 11 | /DEBUG 12 | /_Inline 13 | -------------------------------------------------------------------------------- /.mailmap: -------------------------------------------------------------------------------- 1 | David Golden 2 | David Golden 3 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | sudo: false 3 | perl: 4 | - "blead" 5 | - "5.24" 6 | - "5.22" 7 | - "5.20" 8 | - "5.18" 9 | - "5.16" 10 | - "5.14" 11 | - "5.12" 12 | - "5.10" 13 | - "5.8.8" 14 | matrix: 15 | allow_failures: 16 | - perl: "blead" 17 | before_install: 18 | - git clone git://github.com/travis-perl/helpers ~/travis-perl-helpers 19 | - source ~/travis-perl-helpers/init 20 | - build-perl 21 | - perl -V 22 | install: 23 | - cpan-install --deps # installs prereqs, including recommends 24 | - cpan-install --coverage # installs converage prereqs, if enabled 25 | script: perl Makefile.PL && make test 26 | # N.B. coverage reporting causes test failures and is omitted 27 | -------------------------------------------------------------------------------- /CONTRIBUTING.mkdn: -------------------------------------------------------------------------------- 1 | ## HOW TO CONTRIBUTE 2 | 3 | Thank you for considering contributing to this distribution. This file 4 | contains instructions that will help you work with the source code. 5 | 6 | The distribution is managed with Dist::Zilla. This means than many of the 7 | usual files you might expect are not in the repository, but are generated at 8 | release time, as is much of the documentation. Some generated files are 9 | kept in the repository as a convenience (e.g. Makefile.PL or cpanfile). 10 | 11 | Generally, **you do not need Dist::Zilla to contribute patches**. You do need 12 | Dist::Zilla to create a tarball. See below for guidance. 13 | 14 | ### Getting dependencies 15 | 16 | If you have App::cpanminus 1.6 or later installed, you can use `cpanm` to 17 | satisfy dependencies like this: 18 | 19 | $ cpanm --installdeps . 20 | 21 | Otherwise, look for either a `Makefile.PL` or `cpanfile` file for 22 | a list of dependencies to satisfy. 23 | 24 | ### Running tests 25 | 26 | You can run tests directly using the `prove` tool: 27 | 28 | $ prove -l 29 | $ prove -lv t/some_test_file.t 30 | 31 | For most of my distributions, `prove` is entirely sufficient for you to test any 32 | patches you have. I use `prove` for 99% of my testing during development. 33 | 34 | ### Code style and tidying 35 | 36 | Please try to match any existing coding style. If there is a `.perltidyrc` 37 | file, please install Perl::Tidy and use perltidy before submitting patches. 38 | 39 | If there is a `tidyall.ini` file, you can also install Code::TidyAll and run 40 | `tidyall` on a file or `tidyall -a` to tidy all files. 41 | 42 | ### Patching documentation 43 | 44 | Much of the documentation Pod is generated at release time. Some is 45 | generated boilerplate; other documentation is built from pseudo-POD 46 | directives in the source like C<=method> or C<=func>. 47 | 48 | If you would like to submit a documentation edit, please limit yourself to 49 | the documentation you see. 50 | 51 | If you see typos or documentation issues in the generated docs, please 52 | email or open a bug ticket instead of patching. 53 | 54 | ### Installing and using Dist::Zilla 55 | 56 | Dist::Zilla is a very powerful authoring tool, optimized for maintaining a 57 | large number of distributions with a high degree of automation, but it has a 58 | large dependency chain, a bit of a learning curve and requires a number of 59 | author-specific plugins. 60 | 61 | To install it from CPAN, I recommend one of the following approaches for 62 | the quickest installation: 63 | 64 | # using CPAN.pm, but bypassing non-functional pod tests 65 | $ cpan TAP::Harness::Restricted 66 | $ PERL_MM_USE_DEFAULT=1 HARNESS_CLASS=TAP::Harness::Restricted cpan Dist::Zilla 67 | 68 | # using cpanm, bypassing *all* tests 69 | $ cpanm -n Dist::Zilla 70 | 71 | In either case, it's probably going to take about 10 minutes. Go for a walk, 72 | go get a cup of your favorite beverage, take a bathroom break, or whatever. 73 | When you get back, Dist::Zilla should be ready for you. 74 | 75 | Then you need to install any plugins specific to this distribution: 76 | 77 | $ cpan `dzil authordeps` 78 | $ dzil authordeps | cpanm 79 | 80 | Once installed, here are some dzil commands you might try: 81 | 82 | $ dzil build 83 | $ dzil test 84 | $ dzil xtest 85 | 86 | You can learn more about Dist::Zilla at http://dzil.org/ 87 | 88 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Capture-Tiny 2 | 3 | {{$NEXT}} 4 | 5 | 0.50 2024-12-19 08:15:32-05:00 America/New_York 6 | 7 | - No changes from 0.49-TRIAL 8 | 9 | 0.49 2024-12-16 08:10:22-05:00 America/New_York (TRIAL RELEASE) 10 | 11 | [Internal] 12 | 13 | - Stringify '$]' for far future compatibility. 14 | 15 | [Docs] 16 | 17 | - Fixed docs about custom files for capture 18 | 19 | 0.48 2018-04-22 10:02:47+02:00 Europe/Oslo 20 | 21 | - No changes from 0.47-TRIAL 22 | 23 | 0.47 2017-07-26 10:34:24-04:00 America/New_York (TRIAL RELEASE) 24 | 25 | [Fixed] 26 | 27 | - Appends PID to random file names for tee signalling to avoid 28 | random name collision when used in multiple forked children. 29 | 30 | 0.46 2017-02-25 14:19:22-05:00 America/New_York 31 | 32 | - No changes from 0.45-TRIAL 33 | 34 | 0.45 2017-02-23 13:22:43-05:00 America/New_York (TRIAL RELEASE) 35 | 36 | [Internal] 37 | 38 | - Avoid variable shadowing to improve debuggability. 39 | 40 | 0.44 2016-08-05 13:40:33-04:00 America/New_York 41 | 42 | [Docs] 43 | 44 | - Note that dropping privileges during a capture can lead to 45 | temporary files not cleaned up. 46 | 47 | 0.42 2016-05-31 12:40:10-04:00 America/New_York 48 | 49 | - No changes from 0.41 50 | 51 | 0.41 2016-05-23 11:58:15-04:00 America/New_York (TRIAL RELEASE) 52 | 53 | [Fixed] 54 | 55 | - Fixed some failing tests when STDIN is routed to /dev/null 56 | 57 | 0.40 2016-05-23 11:42:35-04:00 America/New_York 58 | 59 | - No changes from 0.39 60 | 61 | 0.39 2016-05-02 10:21:48-04:00 America/New_York (TRIAL RELEASE) 62 | 63 | [Fixed] 64 | 65 | - Fix in 0.37 tickled a very obscure regular expressions bug in perl < 66 | 5.18; should now be fixed. 67 | 68 | 0.37 2016-05-02 07:08:31-04:00 America/New_York (TRIAL RELEASE) 69 | 70 | [Fixed] 71 | 72 | - Skip some tests if locale can't be determined. 73 | 74 | 0.36 2016-02-28 21:36:57-05:00 America/New_York 75 | 76 | [Docs] 77 | 78 | - Fixed typos. 79 | 80 | 0.34 2016-02-18 23:26:13-05:00 America/New_York 81 | 82 | [Fixed] 83 | 84 | - Removed spurious JSON::PP dependency added by a broken 85 | Dist::Zilla plugin. 86 | 87 | 0.32 2016-02-18 10:12:02-05:00 America/New_York 88 | 89 | [Docs] 90 | 91 | - Changed internal formatting of documentation 92 | 93 | [Changes] 94 | 95 | - No functional changes from 0.31 96 | 97 | 0.31 2016-02-14 07:33:50-07:00 America/Mazatlan (TRIAL RELEASE) 98 | 99 | [Fixed] 100 | 101 | - Application of layers to handles during and after capture now attempts 102 | to more accurately duplicate the original layers, including potential 103 | duplicate layers. Because of the unusual ways that layers are ordered 104 | and applied, exact duplication is not guaranteeed, but this should be 105 | better that what Capture::Tiny did before. 106 | 107 | - Avoids a hard crash on Windows with Perl < 5.20 if a fork occurs in a 108 | capture block. Also documented the risks and lack of support for 109 | forks in capture blocks. 110 | 111 | 0.30 2015-05-15 20:43:54-04:00 America/New_York 112 | 113 | No changes from 0.29 114 | 115 | 0.29 2015-04-19 18:36:24+02:00 Europe/Berlin (TRIAL RELEASE) 116 | 117 | Fixed: 118 | 119 | - Fix double filehandle close error with tee on Windows 120 | (which started warning during the perl 5.21.x series, 121 | causing tests to fail) 122 | 123 | 0.28 2015-02-11 06:39:51-05:00 America/New_York 124 | 125 | Tests: 126 | 127 | - Removes test that optionally uses Inline::C to avoid spurious 128 | test failures. Also Inline::C had become a fairly heavy 129 | (if optional) dependency. 130 | 131 | Docs: 132 | 133 | - Clarify that PERL_CAPTURE_TINY_TIMEOUT is an internal control, 134 | not a timeout of the code reference being captured. 135 | 136 | 0.27 2014-11-04 23:10:44-05:00 America/New_York 137 | 138 | Prereqs: 139 | 140 | - Make Inline::C recommended, not required 141 | 142 | 0.26 2014-11-04 06:55:15-05:00 America/New_York 143 | 144 | Tests: 145 | 146 | - Actually check for Inline::C in tests, not just Inline 147 | 148 | 0.25 2014-08-16 10:08:42-04:00 America/New_York 149 | 150 | Prereqs: 151 | 152 | - Amended recommended modules to list Inline::C rather than Inline 153 | 154 | 0.24 2014-02-06 17:15:37-05:00 America/New_York 155 | 156 | Fixed: 157 | 158 | - Closed security hole in use of semaphore file in /tmp; 159 | now opens the semaphore file using O_CREAT|O_EXCL 160 | 161 | 0.23 2013-10-20 11:25:34 America/New_York 162 | 163 | Fixed: 164 | 165 | - minimum Perl prereq is back to 5.6 (but $diety help you if 166 | you're still stuck on 5.6) 167 | 168 | Documented: 169 | 170 | - Added warning about using @_ in a capture block 171 | 172 | 0.22 2013-03-27 15:50:29 America/New_York 173 | 174 | Documented: 175 | 176 | - Issue tracker is now github 177 | 178 | 0.21 2012-11-14 19:04:49 America/New_York 179 | 180 | Changed: 181 | 182 | - Skips tee and leak tests for closed STDIN on Perl prior to 183 | 5.12 when PERL_UNICODE=D. Documented lack of support as 184 | a known issue. 185 | 186 | - Isolated tee subprocesses from effects of PERL_UNICODE as a 187 | precaution (though this did not fix the above issue). 188 | 189 | - Improved layer detection for handles proxied due to being closed 190 | or tied. 191 | 192 | 0.20 2012-09-19 13:20:57 America/New_York 193 | 194 | Fixed: 195 | 196 | - Nested merged captures that include an external program call no longer 197 | leak STDERR to the outer scope [rt.cpan.org #79376] 198 | 199 | 0.19 2012-08-06 20:26:34 America/New_York 200 | 201 | Fixed: 202 | 203 | - Work around rt.perl.org #114404 by forcing PerlIO layers back on 204 | original handles [rt.cpan.org #78819] 205 | 206 | 0.18 2012-05-04 16:31:53 America/New_York 207 | 208 | Added: 209 | 210 | - When capture or tee are called in void context, Capture::Tiny 211 | skips reading back from the capture handles if it can do so safely 212 | 213 | 0.17_52 2012-03-09 11:45:19 EST5EDT 214 | 215 | Fixed: 216 | 217 | - Tied STDIN is always localized before redirections to avoid tees 218 | hanging on MSWin32 219 | 220 | - Copying and reopening STDIN is necessary to avoid tees hanging on MSWin32. 221 | 222 | 0.17_51 2012-03-07 18:22:34 EST5EDT 223 | 224 | Fixed: 225 | 226 | - Avoids reopening STDIN while setting up a capture, which avoids 227 | some problems with pathological tied filehandle implementations 228 | such as in FCGI 229 | 230 | Tested: 231 | 232 | - Re-enabled tied STDIN testing for MSWin32 to see if changes above 233 | avoid crashes seen historically 234 | 235 | 0.17 2012-02-22 08:07:41 EST5EDT 236 | 237 | Fixed: 238 | 239 | - Added a workaround for failing t/08-stdin-closed.t under blead 240 | perl / 5.15.8 [rt.perl.org #111070] 241 | 242 | Documented: 243 | 244 | - Clarified some limitations; added a link to CPAN Testers Matrix; 245 | removed redundant BUGS section; standardized terminology 246 | 247 | Tested: 248 | 249 | - Added a test using Inline::C to print to stdout and stderr in response 250 | to rt.cpan.org #71701 251 | 252 | 0.16 2012-02-12 21:04:24 EST5EDT 253 | 254 | Documented: 255 | 256 | - Noted problems and workaround for FCGI's pathological tied STDIN 257 | [rt.cpan.org #74681; thank you Karl Gaissmaier for testing the 258 | workaround] 259 | 260 | 0.15 2011-12-23 11:10:47 EST5EDT 261 | 262 | Fixed: 263 | 264 | - Repeated captures from a custom filehandle would return undef instead 265 | of the empty string (and would warn). This has been fixed. 266 | [rt.cpan.org #73374 part two. Thank you to Philipp Herz for help 267 | in reproducing this bug.] 268 | 269 | Other: 270 | 271 | - Commented out debugging code for slightly less runtime overhead 272 | 273 | 0.14 2011-12-22 10:14:09 EST5EDT 274 | 275 | Added: 276 | 277 | - Capturing with custom filehandles will return only newly appended 278 | output instead of everything already in the file. 279 | [rt.cpan.org #73374] 280 | 281 | 0.13 2011-12-02 13:39:00 EST5EDT 282 | 283 | Fixed: 284 | 285 | - Fixed t/18-custom-capture.t failures on Windows due to tempfile 286 | removal problems in the testfile 287 | 288 | 0.12 2011-12-01 16:58:05 EST5EDT 289 | 290 | Added: 291 | 292 | - New functions capture_stdout, capture_stderr, tee_stdout, tee_stderr 293 | [rt.cpan.org #60515] 294 | 295 | - Capture functions also returns the return values from the executed 296 | coderef [rt.cpan.org #61794, adapted from patch by Christian Walde] 297 | 298 | - Capture functions take optional custom filehandles for capturing 299 | via named files instead of anonymous ones [inspired by Christian Walde] 300 | 301 | Fixed: 302 | 303 | - Tied filehandles based on Tie::StdHandle can now use the ":utf8" 304 | layer; removed remaining TODO tests; adds Scalar::Util as a dependency 305 | 306 | Changed: 307 | 308 | - When Time::HiRes::usleep is available, tee operations will 309 | sleep during the busy-loop waiting for tee processes to be ready 310 | [rt.cpan.org #67858] 311 | 312 | 0.11 2011-05-19 23:34:23 America/New_York 313 | 314 | Fixed: 315 | 316 | - Tests will not use Test::Differences version 0.60 or greater 317 | 318 | 0.10 2011-02-07 07:01:44 EST5EDT 319 | 320 | Fixed: 321 | 322 | - Setting PERL_CAPTURE_TINY_TIMEOUT to 0 will disable timeouts 323 | 324 | 0.09 2011-01-27 23:52:16 EST5EDT 325 | 326 | Added: 327 | 328 | - Added support for $ENV{PERL_CAPTURE_TINY_TIMEOUT} to control 329 | the timeout period under 'tee'; tests set not to timeout to 330 | avoid false FAIL reports on overloaded virtual machine smokers 331 | 332 | Fixed: 333 | 334 | - $@ set within a captured block is no longer lost when the capture 335 | is completed; likewise, the initial value of $@ is not lost 336 | during capture (when no subsequent error occurs) (RT #65139) 337 | 338 | 0.08 Sun Jun 20 19:13:19 EDT 2010 339 | 340 | Fixed: 341 | 342 | - Exceptions in captured coderef are caught, then handles are restored 343 | before the exception is rethrown (RT #58208) 344 | 345 | 0.07 Sun Jan 24 00:18:45 EST 2010 346 | 347 | Fixed: 348 | 349 | - Changed test for $? preservation to be more portable 350 | 351 | - Dropped support for Perl 5.8.0 specifically due to excessive bugs. 352 | Tests will bail out. (5.6.X is still supported) 353 | 354 | 0.06 Thu May 7 06:54:53 EDT 2009 355 | 356 | Fixed: 357 | 358 | - On Win32, subprocesses now close themselves on EOF instead of being 359 | killed with a signal 360 | 361 | 0.05_51 Tue Apr 21 07:00:38 EDT 2009 362 | 363 | Added: 364 | 365 | - Support for wide characters on handles opened to utf8 366 | 367 | - Support for STDOUT, STDERR or STDIN opened to in-memory 368 | files (open to scalar reference) or tied, albeit with some limitations 369 | 370 | Testing: 371 | 372 | - Verify that $? is preserved during capture { system(@cmd) }; 373 | 374 | 0.05 Tue Mar 3 06:56:05 EST 2009 375 | 376 | Fixed: 377 | 378 | - On Win32, increased a delay waiting for buffers to flush to avoid losing 379 | final output during tee() 380 | 381 | 0.04 Wed Feb 25 09:25:27 EST 2009 382 | 383 | Added: 384 | 385 | - Can capture/tee even if STDIN, STDOUT or STDERR are closed prior to 386 | capture/tee block 387 | 388 | - Generally, added more error handling 389 | 390 | Fixed: 391 | 392 | - Will timeout instead of hang if subprocesses fail to start 393 | 394 | 0.03 Fri Feb 20 13:03:08 EST 2009 395 | 396 | Added: 397 | 398 | - capture_merged() and tee_merged() 399 | 400 | Fixed: 401 | 402 | - Tests skip if not Win32 and no fork() (rather than Build.PL and 403 | Makefile.PL failing); this allows capture() on odd platforms, even if 404 | fork doesn't work 405 | 406 | 0.02 Tue Feb 17 17:24:35 EST 2009 407 | 408 | Fixed: 409 | 410 | - Bug recovering output when STDOUT is empty (reported by Vincent Pit) 411 | 412 | - Removed Fatal.pm to avoid global action-at-a-distance 413 | 414 | 0.01 Fri Feb 13 23:15:19 EST 2009 415 | 416 | Added: 417 | - 'capture' and 'tee' functions 418 | 419 | # vim: set ts=2 sts=2 sw=2 et tw=75: 420 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use 5.006; 5 | 6 | use ExtUtils::MakeMaker 6.17; 7 | 8 | my %WriteMakefileArgs = ( 9 | "ABSTRACT" => "Capture STDOUT and STDERR from Perl, XS or external programs", 10 | "AUTHOR" => "David Golden ", 11 | "CONFIGURE_REQUIRES" => { 12 | "ExtUtils::MakeMaker" => "6.17" 13 | }, 14 | "DISTNAME" => "Capture-Tiny", 15 | "LICENSE" => "apache", 16 | "MIN_PERL_VERSION" => "5.006", 17 | "NAME" => "Capture::Tiny", 18 | "PREREQ_PM" => { 19 | "Carp" => 0, 20 | "Exporter" => 0, 21 | "File::Spec" => 0, 22 | "File::Temp" => 0, 23 | "IO::Handle" => 0, 24 | "Scalar::Util" => 0, 25 | "strict" => 0, 26 | "warnings" => 0 27 | }, 28 | "TEST_REQUIRES" => { 29 | "ExtUtils::MakeMaker" => 0, 30 | "File::Spec" => 0, 31 | "IO::File" => 0, 32 | "Test::More" => "0.62", 33 | "lib" => 0 34 | }, 35 | "VERSION" => "0.51", 36 | "test" => { 37 | "TESTS" => "t/*.t" 38 | } 39 | ); 40 | 41 | 42 | my %FallbackPrereqs = ( 43 | "Carp" => 0, 44 | "Exporter" => 0, 45 | "ExtUtils::MakeMaker" => 0, 46 | "File::Spec" => 0, 47 | "File::Temp" => 0, 48 | "IO::File" => 0, 49 | "IO::Handle" => 0, 50 | "Scalar::Util" => 0, 51 | "Test::More" => "0.62", 52 | "lib" => 0, 53 | "strict" => 0, 54 | "warnings" => 0 55 | ); 56 | 57 | 58 | unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { 59 | delete $WriteMakefileArgs{TEST_REQUIRES}; 60 | delete $WriteMakefileArgs{BUILD_REQUIRES}; 61 | $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; 62 | } 63 | 64 | delete $WriteMakefileArgs{CONFIGURE_REQUIRES} 65 | unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; 66 | 67 | if ( $^O eq 'MSWin32' ) { 68 | $WriteMakefileArgs{PREREQ_PM}{'Win32API::File'} = $FallbackPrereqs{'Win32API::File'} = '0'; 69 | } 70 | 71 | WriteMakefile(%WriteMakefileArgs); 72 | -------------------------------------------------------------------------------- /README.mkdn: -------------------------------------------------------------------------------- 1 | CONTRIBUTING.mkdn -------------------------------------------------------------------------------- /Todo: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | - Test utf8 output 8 | - Test with curses 9 | -------------------------------------------------------------------------------- /dist.ini: -------------------------------------------------------------------------------- 1 | name = Capture-Tiny 2 | author = David Golden 3 | license = Apache_2_0 4 | copyright_holder = David Golden 5 | copyright_year = 2009 6 | 7 | [@DAGOLDEN] 8 | :version = 0.072 9 | stopwords = UTF 10 | stopwords = seekable 11 | stopwords = prototyped 12 | stopwords = resending 13 | stopwords = undiagnosed 14 | 15 | [ReleaseStatus::FromVersion] 16 | testing = second_decimal_odd 17 | 18 | [OSPrereqs / MSWin32] 19 | Win32API::File = 0 20 | 21 | [RemovePrereqs] 22 | remove = PerlIO 23 | remove = PerlIO::scalar 24 | remove = Test::Differences 25 | ; tests optionally require 5.008 26 | remove = perl 27 | 28 | [Prereqs] 29 | perl = 5.006 30 | -------------------------------------------------------------------------------- /examples/rt-58208.pl: -------------------------------------------------------------------------------- 1 | use Capture::Tiny qw[ capture ]; 2 | 3 | my ( $out, $err ) = 4 | eval { capture { print STDERR "hello\n"; print STDOUT "there\n"; die("foo\n" ) } }; 5 | 6 | print STDERR "STDERR:\nout=$out\nerr=$err\n\$@=$@"; 7 | print STDOUT "STDOUT:\nout=$out\nerr=$err\n\$@=$@"; 8 | 9 | open FILE, '>ttt.log' or die( "error opening logfile\n" ); 10 | print FILE "FILE:\nout=$out\nerr=$err\n\$@=$@\n"; 11 | close FILE; 12 | -------------------------------------------------------------------------------- /examples/tee.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Capture::Tiny qw/capture tee/; 5 | 6 | print "Type some text. Type 'exit' to quit\n"; 7 | my ($out, $err) = tee { 8 | while (<>) { 9 | last if /^exit$/; 10 | print "Echoing to STDOUT: $_"; 11 | print STDERR "Echoing to STDERR: $_"; 12 | } 13 | }; 14 | 15 | print "\nCaptured STDOUT was:\n" . ( defined $out ? $out : 'undef' ); 16 | print "\nCaptured STDERR was:\n" . ( defined $err ? $err : 'undef' ); 17 | 18 | 19 | -------------------------------------------------------------------------------- /lib/Capture/Tiny.pm: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | package Capture::Tiny; 5 | # ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs 6 | our $VERSION = '0.51'; 7 | use Carp (); 8 | use Exporter (); 9 | use IO::Handle (); 10 | use File::Spec (); 11 | use File::Temp qw/tempfile tmpnam/; 12 | use Scalar::Util qw/reftype blessed/; 13 | # Get PerlIO or fake it 14 | BEGIN { 15 | local $@; 16 | eval { require PerlIO; PerlIO->can('get_layers') } 17 | or *PerlIO::get_layers = sub { return () }; 18 | } 19 | 20 | #--------------------------------------------------------------------------# 21 | # create API subroutines and export them 22 | # [do STDOUT flag, do STDERR flag, do merge flag, do tee flag] 23 | #--------------------------------------------------------------------------# 24 | 25 | my %api = ( 26 | capture => [1,1,0,0], 27 | capture_stdout => [1,0,0,0], 28 | capture_stderr => [0,1,0,0], 29 | capture_merged => [1,1,1,0], 30 | tee => [1,1,0,1], 31 | tee_stdout => [1,0,0,1], 32 | tee_stderr => [0,1,0,1], 33 | tee_merged => [1,1,1,1], 34 | ); 35 | 36 | for my $sub ( keys %api ) { 37 | my $args = join q{, }, @{$api{$sub}}; 38 | eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic 39 | } 40 | 41 | our @ISA = qw/Exporter/; 42 | our @EXPORT_OK = keys %api; 43 | our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); 44 | 45 | #--------------------------------------------------------------------------# 46 | # constants and fixtures 47 | #--------------------------------------------------------------------------# 48 | 49 | my $IS_WIN32 = $^O eq 'MSWin32'; 50 | 51 | ##our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG}; 52 | ## 53 | ##my $DEBUGFH; 54 | ##open $DEBUGFH, "> DEBUG" if $DEBUG; 55 | ## 56 | ##*_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0}; 57 | 58 | our $TIMEOUT = 30; 59 | 60 | #--------------------------------------------------------------------------# 61 | # command to tee output -- the argument is a filename that must 62 | # be opened to signal that the process is ready to receive input. 63 | # This is annoying, but seems to be the best that can be done 64 | # as a simple, portable IPC technique 65 | #--------------------------------------------------------------------------# 66 | my @cmd = ($^X, '-C0', '-e', <<'HERE'); 67 | use Fcntl; 68 | $SIG{HUP}=sub{exit}; 69 | if ( my $fn=shift ) { 70 | sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!; 71 | print {$fh} $$; 72 | close $fh; 73 | } 74 | my $buf; while (sysread(STDIN, $buf, 2048)) { 75 | syswrite(STDOUT, $buf); syswrite(STDERR, $buf); 76 | } 77 | HERE 78 | 79 | #--------------------------------------------------------------------------# 80 | # filehandle manipulation 81 | #--------------------------------------------------------------------------# 82 | 83 | sub _relayer { 84 | my ($fh, $apply_layers) = @_; 85 | # _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n"); 86 | 87 | # eliminate pseudo-layers 88 | binmode( $fh, ":raw" ); 89 | # strip off real layers until only :unix is left 90 | while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) { 91 | binmode( $fh, ":pop" ); 92 | } 93 | # apply other layers 94 | my @to_apply = @$apply_layers; 95 | shift @to_apply; # eliminate initial :unix 96 | # _debug("# applying layers (unix @to_apply) to @{[fileno $fh]}\n"); 97 | binmode($fh, ":" . join(":",@to_apply)); 98 | } 99 | 100 | sub _name { 101 | my $glob = shift; 102 | no strict 'refs'; ## no critic 103 | return *{$glob}{NAME}; 104 | } 105 | 106 | sub _open { 107 | open $_[0], $_[1] or Carp::confess "Error from open(" . join(q{, }, @_) . "): $!"; 108 | # _debug( "# open " . join( ", " , map { defined $_ ? _name($_) : 'undef' } @_ ) . " as " . fileno( $_[0] ) . "\n" ); 109 | } 110 | 111 | sub _close { 112 | # _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' ) . " on " . fileno( $_[0] ) . "\n" ); 113 | close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!"; 114 | } 115 | 116 | my %dup; # cache this so STDIN stays fd0 117 | my %proxy_count; 118 | sub _proxy_std { 119 | my %proxies; 120 | if ( ! defined fileno STDIN ) { 121 | $proxy_count{stdin}++; 122 | if (defined $dup{stdin}) { 123 | _open \*STDIN, "<&=" . fileno($dup{stdin}); 124 | # _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); 125 | } 126 | else { 127 | _open \*STDIN, "<" . File::Spec->devnull; 128 | # _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); 129 | _open $dup{stdin} = IO::Handle->new, "<&=STDIN"; 130 | } 131 | $proxies{stdin} = \*STDIN; 132 | binmode(STDIN, ':utf8') if $] >= 5.008; ## no critic 133 | } 134 | if ( ! defined fileno STDOUT ) { 135 | $proxy_count{stdout}++; 136 | if (defined $dup{stdout}) { 137 | _open \*STDOUT, ">&=" . fileno($dup{stdout}); 138 | # _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); 139 | } 140 | else { 141 | _open \*STDOUT, ">" . File::Spec->devnull; 142 | # _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); 143 | _open $dup{stdout} = IO::Handle->new, ">&=STDOUT"; 144 | } 145 | $proxies{stdout} = \*STDOUT; 146 | binmode(STDOUT, ':utf8') if $] >= 5.008; ## no critic 147 | } 148 | if ( ! defined fileno STDERR ) { 149 | $proxy_count{stderr}++; 150 | if (defined $dup{stderr}) { 151 | _open \*STDERR, ">&=" . fileno($dup{stderr}); 152 | # _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); 153 | } 154 | else { 155 | _open \*STDERR, ">" . File::Spec->devnull; 156 | # _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); 157 | _open $dup{stderr} = IO::Handle->new, ">&=STDERR"; 158 | } 159 | $proxies{stderr} = \*STDERR; 160 | binmode(STDERR, ':utf8') if $] >= 5.008; ## no critic 161 | } 162 | return %proxies; 163 | } 164 | 165 | sub _unproxy { 166 | my (%proxies) = @_; 167 | # _debug( "# unproxying: " . join(" ", keys %proxies) . "\n" ); 168 | for my $p ( keys %proxies ) { 169 | $proxy_count{$p}--; 170 | # _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" ); 171 | if ( ! $proxy_count{$p} ) { 172 | _close $proxies{$p}; 173 | _close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup 174 | delete $dup{$p}; 175 | } 176 | } 177 | } 178 | 179 | sub _copy_std { 180 | my %handles; 181 | for my $h ( qw/stdout stderr stdin/ ) { 182 | next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied 183 | my $redir = $h eq 'stdin' ? "<&" : ">&"; 184 | _open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN" 185 | } 186 | return \%handles; 187 | } 188 | 189 | # In some cases we open all (prior to forking) and in others we only open 190 | # the output handles (setting up redirection) 191 | sub _open_std { 192 | my ($handles) = @_; 193 | _open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin}; 194 | _open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout}; 195 | _open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr}; 196 | } 197 | 198 | #--------------------------------------------------------------------------# 199 | # private subs 200 | #--------------------------------------------------------------------------# 201 | 202 | sub _start_tee { 203 | my ($which, $stash) = @_; # $which is "stdout" or "stderr" 204 | # setup pipes 205 | $stash->{$_}{$which} = IO::Handle->new for qw/tee reader/; 206 | pipe $stash->{reader}{$which}, $stash->{tee}{$which}; 207 | # _debug( "# pipe for $which\: " . _name($stash->{tee}{$which}) . " " . fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which}) . " " . fileno( $stash->{reader}{$which}) . "\n" ); 208 | select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush 209 | # setup desired redirection for parent and child 210 | $stash->{new}{$which} = $stash->{tee}{$which}; 211 | $stash->{child}{$which} = { 212 | stdin => $stash->{reader}{$which}, 213 | stdout => $stash->{old}{$which}, 214 | stderr => $stash->{capture}{$which}, 215 | }; 216 | # flag file is used to signal the child is ready 217 | $stash->{flag_files}{$which} = scalar( tmpnam() ) . $$; 218 | # execute @cmd as a separate process 219 | if ( $IS_WIN32 ) { 220 | my $old_eval_err=$@; 221 | undef $@; 222 | 223 | eval "use Win32API::File qw/GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ "; 224 | # _debug( "# Win32API::File loaded\n") unless $@; 225 | my $os_fhandle = GetOsFHandle( $stash->{tee}{$which} ); 226 | # _debug( "# Couldn't get OS handle: " . fileLastError() . "\n") if ! defined $os_fhandle || $os_fhandle == INVALID_HANDLE_VALUE(); 227 | my $result = SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0); 228 | # _debug( $result ? "# set no-inherit flag on $which tee\n" : ("# can't disable tee handle flag inherit: " . fileLastError() . "\n")); 229 | _open_std( $stash->{child}{$which} ); 230 | $stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which}); 231 | # not restoring std here as it all gets redirected again shortly anyway 232 | $@=$old_eval_err; 233 | } 234 | else { # use fork 235 | _fork_exec( $which, $stash ); 236 | } 237 | } 238 | 239 | sub _fork_exec { 240 | my ($which, $stash) = @_; # $which is "stdout" or "stderr" 241 | my $pid = fork; 242 | if ( not defined $pid ) { 243 | Carp::confess "Couldn't fork(): $!"; 244 | } 245 | elsif ($pid == 0) { # child 246 | # _debug( "# in child process ...\n" ); 247 | untie *STDIN; untie *STDOUT; untie *STDERR; 248 | _close $stash->{tee}{$which}; 249 | # _debug( "# redirecting handles in child ...\n" ); 250 | _open_std( $stash->{child}{$which} ); 251 | # _debug( "# calling exec on command ...\n" ); 252 | exec @cmd, $stash->{flag_files}{$which}; 253 | } 254 | $stash->{pid}{$which} = $pid 255 | } 256 | 257 | my $have_usleep = eval "use Time::HiRes 'usleep'; 1"; 258 | sub _files_exist { 259 | return 1 if @_ == grep { -f } @_; 260 | Time::HiRes::usleep(1000) if $have_usleep; 261 | return 0; 262 | } 263 | 264 | sub _wait_for_tees { 265 | my ($stash) = @_; 266 | my $start = time; 267 | my @files = values %{$stash->{flag_files}}; 268 | my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT} 269 | ? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT; 270 | 1 until _files_exist(@files) || ($timeout && (time - $start > $timeout)); 271 | Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files); 272 | unlink $_ for @files; 273 | } 274 | 275 | sub _kill_tees { 276 | my ($stash) = @_; 277 | if ( $IS_WIN32 ) { 278 | # _debug( "# closing handles\n"); 279 | close($_) for values %{ $stash->{tee} }; 280 | # _debug( "# waiting for subprocesses to finish\n"); 281 | my $start = time; 282 | 1 until wait == -1 || (time - $start > 30); 283 | } 284 | else { 285 | _close $_ for values %{ $stash->{tee} }; 286 | waitpid $_, 0 for values %{ $stash->{pid} }; 287 | } 288 | } 289 | 290 | sub _slurp { 291 | my ($name, $stash) = @_; 292 | my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/; 293 | # _debug( "# slurping captured $name from " . fileno($fh) . " at pos $pos with layers: @{[PerlIO::get_layers($fh)]}\n"); 294 | seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n"; 295 | my $text = do { local $/; scalar readline $fh }; 296 | return defined($text) ? $text : ""; 297 | } 298 | 299 | #--------------------------------------------------------------------------# 300 | # _capture_tee() -- generic main sub for capturing or teeing 301 | #--------------------------------------------------------------------------# 302 | 303 | sub _capture_tee { 304 | # _debug( "# starting _capture_tee with (@_)...\n" ); 305 | my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_; 306 | my %do = ($do_stdout ? (stdout => 1) : (), $do_stderr ? (stderr => 1) : ()); 307 | Carp::confess("Custom capture options must be given as key/value pairs\n") 308 | unless @opts % 2 == 0; 309 | my $stash = { capture => { @opts } }; 310 | for ( keys %{$stash->{capture}} ) { 311 | my $fh = $stash->{capture}{$_}; 312 | Carp::confess "Custom handle for $_ must be seekable\n" 313 | unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable")); 314 | } 315 | # save existing filehandles and setup captures 316 | local *CT_ORIG_STDIN = *STDIN ; 317 | local *CT_ORIG_STDOUT = *STDOUT; 318 | local *CT_ORIG_STDERR = *STDERR; 319 | # find initial layers 320 | my %layers = ( 321 | stdin => [PerlIO::get_layers(\*STDIN) ], 322 | stdout => [PerlIO::get_layers(\*STDOUT, output => 1)], 323 | stderr => [PerlIO::get_layers(\*STDERR, output => 1)], 324 | ); 325 | # _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; 326 | # get layers from underlying glob of tied filehandles if we can 327 | # (this only works for things that work like Tie::StdHandle) 328 | $layers{stdout} = [PerlIO::get_layers(tied *STDOUT)] 329 | if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB'); 330 | $layers{stderr} = [PerlIO::get_layers(tied *STDERR)] 331 | if tied(*STDERR) && (reftype tied *STDERR eq 'GLOB'); 332 | # _debug( "# tied object corrected layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; 333 | # bypass scalar filehandles and tied handles 334 | # localize scalar STDIN to get a proxy to pick up FD0, then restore later to CT_ORIG_STDIN 335 | my %localize; 336 | $localize{stdin}++, local(*STDIN) 337 | if grep { $_ eq 'scalar' } @{$layers{stdin}}; 338 | $localize{stdout}++, local(*STDOUT) 339 | if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}}; 340 | $localize{stderr}++, local(*STDERR) 341 | if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}}; 342 | $localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0") 343 | if tied *STDIN && $] >= 5.008; 344 | $localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1") 345 | if $do_stdout && tied *STDOUT && $] >= 5.008; 346 | $localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2") 347 | if ($do_stderr || $do_merge) && tied *STDERR && $] >= 5.008; 348 | # _debug( "# localized $_\n" ) for keys %localize; 349 | # proxy any closed/localized handles so we don't use fds 0, 1 or 2 350 | my %proxy_std = _proxy_std(); 351 | # _debug( "# proxy std: @{ [%proxy_std] }\n" ); 352 | # update layers after any proxying 353 | $layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout}; 354 | $layers{stderr} = [PerlIO::get_layers(\*STDERR, output => 1)] if $proxy_std{stderr}; 355 | # _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; 356 | # store old handles and setup handles for capture 357 | $stash->{old} = _copy_std(); 358 | $stash->{new} = { %{$stash->{old}} }; # default to originals 359 | for ( keys %do ) { 360 | $stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new); 361 | seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n"; 362 | $stash->{pos}{$_} = tell $stash->{capture}{$_}; 363 | # _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" ); 364 | _start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new} 365 | } 366 | _wait_for_tees( $stash ) if $do_tee; 367 | # finalize redirection 368 | $stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge; 369 | # _debug( "# redirecting in parent ...\n" ); 370 | _open_std( $stash->{new} ); 371 | # execute user provided code 372 | my ($exit_code, $inner_error, $outer_error, $orig_pid, @result); 373 | { 374 | $orig_pid = $$; 375 | local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN 376 | # _debug( "# finalizing layers ...\n" ); 377 | _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; 378 | _relayer(\*STDERR, $layers{stderr}) if $do_stderr; 379 | # _debug( "# running code $code ...\n" ); 380 | my $old_eval_err=$@; 381 | undef $@; 382 | eval { @result = $code->(); $inner_error = $@ }; 383 | $exit_code = $?; # save this for later 384 | $outer_error = $@; # save this for later 385 | STDOUT->flush if $do_stdout; 386 | STDERR->flush if $do_stderr; 387 | $@ = $old_eval_err; 388 | } 389 | # restore prior filehandles and shut down tees 390 | # _debug( "# restoring filehandles ...\n" ); 391 | _open_std( $stash->{old} ); 392 | _close( $_ ) for values %{$stash->{old}}; # don't leak fds 393 | # shouldn't need relayering originals, but see rt.perl.org #114404 394 | _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; 395 | _relayer(\*STDERR, $layers{stderr}) if $do_stderr; 396 | _unproxy( %proxy_std ); 397 | # _debug( "# killing tee subprocesses ...\n" ) if $do_tee; 398 | _kill_tees( $stash ) if $do_tee; 399 | # return captured output, but shortcut in void context 400 | # unless we have to echo output to tied/scalar handles; 401 | my %got; 402 | if ( $orig_pid == $$ and ( defined wantarray or ($do_tee && keys %localize) ) ) { 403 | for ( keys %do ) { 404 | _relayer($stash->{capture}{$_}, $layers{$_}); 405 | $got{$_} = _slurp($_, $stash); 406 | # _debug("# slurped " . length($got{$_}) . " bytes from $_\n"); 407 | } 408 | print CT_ORIG_STDOUT $got{stdout} 409 | if $do_stdout && $do_tee && $localize{stdout}; 410 | print CT_ORIG_STDERR $got{stderr} 411 | if $do_stderr && $do_tee && $localize{stderr}; 412 | } 413 | $? = $exit_code; 414 | $@ = $inner_error if $inner_error; 415 | die $outer_error if $outer_error; 416 | # _debug( "# ending _capture_tee with (@_)...\n" ); 417 | return unless defined wantarray; 418 | my @return; 419 | push @return, $got{stdout} if $do_stdout; 420 | push @return, $got{stderr} if $do_stderr && ! $do_merge; 421 | push @return, @result; 422 | return wantarray ? @return : $return[0]; 423 | } 424 | 425 | 1; 426 | 427 | __END__ 428 | 429 | =pod 430 | 431 | =head1 SYNOPSIS 432 | 433 | use Capture::Tiny ':all'; 434 | 435 | # capture from external command 436 | 437 | ($stdout, $stderr, $exit) = capture { 438 | system( $cmd, @args ); 439 | }; 440 | 441 | # capture from arbitrary code (Perl or external) 442 | 443 | ($stdout, $stderr, @result) = capture { 444 | # your code here 445 | }; 446 | 447 | # capture partial or merged output 448 | 449 | $stdout = capture_stdout { ... }; 450 | $stderr = capture_stderr { ... }; 451 | $merged = capture_merged { ... }; 452 | 453 | # tee output 454 | 455 | ($stdout, $stderr) = tee { 456 | # your code here 457 | }; 458 | 459 | $stdout = tee_stdout { ... }; 460 | $stderr = tee_stderr { ... }; 461 | $merged = tee_merged { ... }; 462 | 463 | =head1 DESCRIPTION 464 | 465 | Capture::Tiny provides a simple, portable way to capture almost anything sent 466 | to STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or 467 | from an external program. Optionally, output can be teed so that it is 468 | captured while being passed through to the original filehandles. Yes, it even 469 | works on Windows (usually). Stop guessing which of a dozen capturing modules 470 | to use in any particular situation and just use this one. 471 | 472 | =head1 USAGE 473 | 474 | The following functions are available. None are exported by default. 475 | 476 | =head2 capture 477 | 478 | ($stdout, $stderr, @result) = capture \&code; 479 | $stdout = capture \&code; 480 | 481 | The C function takes a code reference and returns what is sent to 482 | STDOUT and STDERR as well as any return values from the code reference. In 483 | scalar context, it returns only STDOUT. If no output was received for a 484 | filehandle, it returns an empty string for that filehandle. Regardless of calling 485 | context, all output is captured -- nothing is passed to the existing filehandles. 486 | 487 | It is prototyped to take a subroutine reference as an argument. Thus, it 488 | can be called in block form: 489 | 490 | ($stdout, $stderr) = capture { 491 | # your code here ... 492 | }; 493 | 494 | Note that the coderef is evaluated in list context. If you wish to force 495 | scalar context on the return value, you must use the C keyword. 496 | 497 | ($stdout, $stderr, $count) = capture { 498 | my @list = qw/one two three/; 499 | return scalar @list; # $count will be 3 500 | }; 501 | 502 | Also note that within the coderef, the C<@_> variable will be empty. So don't 503 | use arguments from a surrounding subroutine without copying them to an array 504 | first: 505 | 506 | sub wont_work { 507 | my ($stdout, $stderr) = capture { do_stuff( @_ ) }; # WRONG 508 | ... 509 | } 510 | 511 | sub will_work { 512 | my @args = @_; 513 | my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT 514 | ... 515 | } 516 | 517 | Captures are normally done to an anonymous temporary filehandle. To 518 | capture via a named file (e.g. to externally monitor a long-running capture), 519 | provide custom filehandles as a trailing list of option pairs: 520 | 521 | my $out_fh = IO::File->new("out.txt", "w+"); 522 | my $err_fh = IO::File->new("err.txt", "w+"); 523 | capture { ... } stdout => $out_fh, stderr => $err_fh; 524 | 525 | The filehandles must be read/write and seekable. Modifying the files or 526 | filehandles during a capture operation will give unpredictable results. 527 | Existing IO layers on them may be changed by the capture. 528 | 529 | When called in void context, C saves memory and time by 530 | not reading back from the capture handles. 531 | 532 | =head2 capture_stdout 533 | 534 | ($stdout, @result) = capture_stdout \&code; 535 | $stdout = capture_stdout \&code; 536 | 537 | The C function works just like C except only 538 | STDOUT is captured. STDERR is not captured. 539 | 540 | =head2 capture_stderr 541 | 542 | ($stderr, @result) = capture_stderr \&code; 543 | $stderr = capture_stderr \&code; 544 | 545 | The C function works just like C except only 546 | STDERR is captured. STDOUT is not captured. 547 | 548 | =head2 capture_merged 549 | 550 | ($merged, @result) = capture_merged \&code; 551 | $merged = capture_merged \&code; 552 | 553 | The C function works just like C except STDOUT and 554 | STDERR are merged. (Technically, STDERR is redirected to the same capturing 555 | handle as STDOUT before executing the function.) 556 | 557 | Caution: STDOUT and STDERR output in the merged result are not guaranteed to be 558 | properly ordered due to buffering. 559 | 560 | =head2 tee 561 | 562 | ($stdout, $stderr, @result) = tee \&code; 563 | $stdout = tee \&code; 564 | 565 | The C function works just like C, except that output is captured 566 | as well as passed on to the original STDOUT and STDERR. 567 | 568 | When called in void context, C saves memory and time by 569 | not reading back from the capture handles, except when the 570 | original STDOUT or STDERR were tied or opened to a scalar 571 | handle. 572 | 573 | =head2 tee_stdout 574 | 575 | ($stdout, @result) = tee_stdout \&code; 576 | $stdout = tee_stdout \&code; 577 | 578 | The C function works just like C except only 579 | STDOUT is teed. STDERR is not teed (output goes to STDERR as usual). 580 | 581 | =head2 tee_stderr 582 | 583 | ($stderr, @result) = tee_stderr \&code; 584 | $stderr = tee_stderr \&code; 585 | 586 | The C function works just like C except only 587 | STDERR is teed. STDOUT is not teed (output goes to STDOUT as usual). 588 | 589 | =head2 tee_merged 590 | 591 | ($merged, @result) = tee_merged \&code; 592 | $merged = tee_merged \&code; 593 | 594 | The C function works just like C except that output 595 | is captured as well as passed on to STDOUT. 596 | 597 | Caution: STDOUT and STDERR output in the merged result are not guaranteed to be 598 | properly ordered due to buffering. 599 | 600 | =head1 LIMITATIONS 601 | 602 | =head2 Portability 603 | 604 | Portability is a goal, not a guarantee. C requires fork, except on 605 | Windows where C is used instead. Not tested on any 606 | particularly esoteric platforms yet. See the 607 | L 608 | for test result by platform. 609 | 610 | =head2 PerlIO layers 611 | 612 | Capture::Tiny does its best to preserve PerlIO layers such as ':utf8' or 613 | ':crlf' when capturing (only for Perl 5.8.1+) . Layers should be applied to 614 | STDOUT or STDERR I the call to C or C. This may not work 615 | for tied filehandles (see below). 616 | 617 | =head2 Modifying filehandles before capturing 618 | 619 | Generally speaking, you should do little or no manipulation of the standard IO 620 | filehandles prior to using Capture::Tiny. In particular, closing, reopening, 621 | localizing or tying standard filehandles prior to capture may cause a variety of 622 | unexpected, undesirable and/or unreliable behaviors, as described below. 623 | Capture::Tiny does its best to compensate for these situations, but the 624 | results may not be what you desire. 625 | 626 | =head3 Closed filehandles 627 | 628 | Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously 629 | closed. However, since they will be reopened to capture or tee output, any 630 | code within the captured block that depends on finding them closed will, of 631 | course, not find them to be closed. If they started closed, Capture::Tiny will 632 | close them again when the capture block finishes. 633 | 634 | Note that this reopening will happen even for STDIN or a filehandle not being 635 | captured to ensure that the filehandle used for capture is not opened to file 636 | descriptor 0, as this causes problems on various platforms. 637 | 638 | Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles 639 | and also breaks tee() for undiagnosed reasons. So don't do that. 640 | 641 | =head3 Localized filehandles 642 | 643 | If code localizes any of Perl's standard filehandles before capturing, the capture 644 | will affect the localized filehandles and not the original ones. External system 645 | calls are not affected by localizing a filehandle in Perl and will continue 646 | to send output to the original filehandles (which will thus not be captured). 647 | 648 | =head3 Scalar filehandles 649 | 650 | If STDOUT or STDERR are reopened to scalar filehandles prior to the call to 651 | C or C, then Capture::Tiny will override the output filehandle for 652 | the duration of the C or C call and then, for C, send captured 653 | output to the output filehandle after the capture is complete. (Requires Perl 654 | 5.8) 655 | 656 | Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar 657 | reference, but note that external processes will not be able to read from such 658 | a handle. Capture::Tiny tries to ensure that external processes will read from 659 | the null device instead, but this is not guaranteed. 660 | 661 | =head3 Tied output filehandles 662 | 663 | If STDOUT or STDERR are tied prior to the call to C or C, then 664 | Capture::Tiny will attempt to override the tie for the duration of the 665 | C or C call and then send captured output to the tied filehandle after 666 | the capture is complete. (Requires Perl 5.8) 667 | 668 | Capture::Tiny may not succeed resending UTF-8 encoded data to a tied 669 | STDOUT or STDERR filehandle. Characters may appear as bytes. If the tied filehandle 670 | is based on L, then Capture::Tiny will attempt to determine 671 | appropriate layers like C<:utf8> from the underlying filehandle and do the right 672 | thing. 673 | 674 | =head3 Tied input filehandle 675 | 676 | Capture::Tiny attempts to preserve the semantics of tied STDIN, but this 677 | requires Perl 5.8 and is not entirely predictable. External processes 678 | will not be able to read from such a handle. 679 | 680 | Unless having STDIN tied is crucial, it may be safest to localize STDIN when 681 | capturing: 682 | 683 | my ($out, $err) = do { local *STDIN; capture { ... } }; 684 | 685 | =head2 Modifying filehandles during a capture 686 | 687 | Attempting to modify STDIN, STDOUT or STDERR I C or C is 688 | almost certainly going to cause problems. Don't do that. 689 | 690 | =head3 Forking inside a capture 691 | 692 | Forks aren't portable. The behavior of filehandles during a fork is even 693 | less so. If Capture::Tiny detects that a fork has occurred within a 694 | capture, it will shortcut in the child process and return empty strings for 695 | captures. Other problems may occur in the child or parent, as well. 696 | Forking in a capture block is not recommended. 697 | 698 | =head3 Using threads 699 | 700 | Filehandles are global. Mixing up I/O and captures in different threads 701 | without coordination is going to cause problems. Besides, threads are 702 | officially discouraged. 703 | 704 | =head3 Dropping privileges during a capture 705 | 706 | If you drop privileges during a capture, temporary files created to 707 | facilitate the capture may not be cleaned up afterwards. 708 | 709 | =head2 No support for Perl 5.8.0 710 | 711 | It's just too buggy when it comes to layers and UTF-8. Perl 5.8.1 or later 712 | is recommended. 713 | 714 | =head2 Limited support for Perl 5.6 715 | 716 | Perl 5.6 predates PerlIO. UTF-8 data may not be captured correctly. 717 | 718 | =head1 ENVIRONMENT 719 | 720 | =head2 PERL_CAPTURE_TINY_TIMEOUT 721 | 722 | Capture::Tiny uses subprocesses internally for C. By default, 723 | Capture::Tiny will timeout with an error if such subprocesses are not ready to 724 | receive data within 30 seconds (or whatever is the value of 725 | C<$Capture::Tiny::TIMEOUT>). An alternate timeout may be specified by setting 726 | the C environment variable. Setting it to zero will 727 | disable timeouts. B, this does not timeout the code reference being 728 | captured -- this only prevents Capture::Tiny itself from hanging your process 729 | waiting for its child processes to be ready to proceed. 730 | 731 | =head1 SEE ALSO 732 | 733 | This module was inspired by L, which provides 734 | similar functionality without the ability to tee output and with more 735 | complicated code and API. L does not handle layers 736 | or most of the unusual cases described in the L section and 737 | I no longer recommend it. 738 | 739 | There are many other CPAN modules that provide some sort of output capture, 740 | albeit with various limitations that make them appropriate only in particular 741 | circumstances. I'm probably missing some. The long list is provided to show 742 | why I felt Capture::Tiny was necessary. 743 | 744 | =for :list 745 | * L 746 | * L 747 | * L 748 | * L 749 | * L 750 | * L 751 | * L 752 | * L 753 | * L 754 | * L 755 | * L 756 | * L 757 | * L 758 | * L 759 | * L 760 | * L 761 | * L 762 | * L 763 | * L 764 | * L 765 | * L 766 | 767 | =cut 768 | 769 | -------------------------------------------------------------------------------- /perlcritic.rc: -------------------------------------------------------------------------------- 1 | severity = 5 2 | verbose = 8 3 | 4 | [Variables::ProhibitPunctuationVars] 5 | allow = $@ $! 6 | 7 | [TestingAndDebugging::ProhibitNoStrict] 8 | allow = refs 9 | 10 | [Variables::ProhibitEvilVariables] 11 | variables = $DB::single 12 | 13 | # Turn these off 14 | [-BuiltinFunctions::ProhibitStringyEval] 15 | [-ControlStructures::ProhibitPostfixControls] 16 | [-ControlStructures::ProhibitUnlessBlocks] 17 | [-Documentation::RequirePodSections] 18 | [-InputOutput::ProhibitInteractiveTest] 19 | [-References::ProhibitDoubleSigils] 20 | [-RegularExpressions::RequireExtendedFormatting] 21 | [-InputOutput::ProhibitTwoArgOpen] 22 | [-Modules::ProhibitEvilModules] 23 | 24 | # Turn this on 25 | [Lax::ProhibitStringyEval::ExceptForRequire] 26 | 27 | -------------------------------------------------------------------------------- /t/01-Capture-Tiny.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | 10 | use Test::More 0.62; 11 | 12 | my @api = qw( 13 | capture 14 | capture_stdout 15 | capture_stderr 16 | capture_merged 17 | tee 18 | tee_stdout 19 | tee_stderr 20 | tee_merged 21 | ); 22 | 23 | plan tests => 2 + 2 * @api; 24 | 25 | if ( $] eq '5.008' ) { 26 | BAIL_OUT("OS unsupported: Perl 5.8.0 is too buggy for Capture::Tiny"); 27 | } 28 | 29 | require_ok( 'Capture::Tiny' ); 30 | 31 | can_ok('Capture::Tiny', $_) for @api; 32 | 33 | ok( eval "package Foo; use Capture::Tiny ':all'; 1", "import ':all' to Foo" ); 34 | 35 | can_ok('Foo', $_) for @api; 36 | 37 | exit 0; 38 | -------------------------------------------------------------------------------- /t/02-capture.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/next_fd/; 12 | use Cases qw/run_test/; 13 | 14 | plan 'no_plan'; 15 | 16 | my $builder = Test::More->builder; 17 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 18 | 19 | my $fd = next_fd; 20 | 21 | run_test('capture'); 22 | run_test('capture_scalar'); 23 | run_test('capture_stdout'); 24 | run_test('capture_stderr'); 25 | run_test('capture_merged'); 26 | 27 | is( next_fd, $fd, "no file descriptors leaked" ); 28 | 29 | exit 0; 30 | -------------------------------------------------------------------------------- /t/03-tee.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/next_fd/; 12 | use Cases qw/run_test/; 13 | 14 | use Config; 15 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 16 | if ( $no_fork ) { 17 | plan skip_all => 'tee() requires fork'; 18 | } 19 | else { 20 | plan 'no_plan'; 21 | } 22 | 23 | my $builder = Test::More->builder; 24 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 25 | 26 | my $fd = next_fd; 27 | 28 | run_test('tee'); 29 | run_test('tee_scalar'); 30 | run_test('tee_stdout'); 31 | run_test('tee_stderr'); 32 | run_test('tee_merged'); 33 | 34 | is( next_fd, $fd, "no file descriptors leaked" ); 35 | 36 | exit 0; 37 | -------------------------------------------------------------------------------- /t/06-stdout-closed.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/save_std restore_std next_fd/; 12 | use Cases qw/run_test/; 13 | 14 | use Config; 15 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 16 | 17 | plan 'no_plan'; 18 | 19 | my $builder = Test::More->builder; 20 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 21 | 22 | save_std(qw/stdout/); 23 | ok( close STDOUT, "closed STDOUT" ); 24 | 25 | my $fd = next_fd; 26 | 27 | run_test($_) for qw( 28 | capture 29 | capture_scalar 30 | capture_stdout 31 | capture_stderr 32 | capture_merged 33 | ); 34 | 35 | if ( ! $no_fork ) { 36 | run_test($_) for qw( 37 | tee 38 | tee_scalar 39 | tee_stdout 40 | tee_stderr 41 | tee_merged 42 | ); 43 | } 44 | 45 | is( next_fd, $fd, "no file descriptors leaked" ); 46 | restore_std(qw/stdout/); 47 | 48 | exit 0; 49 | 50 | -------------------------------------------------------------------------------- /t/07-stderr-closed.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/save_std restore_std next_fd/; 12 | use Cases qw/run_test/; 13 | 14 | use Config; 15 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 16 | 17 | plan 'no_plan'; 18 | 19 | my $builder = Test::More->builder; 20 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 21 | 22 | save_std(qw/stderr/); 23 | ok( close STDERR, "closed STDERR" ); 24 | 25 | my $fd = next_fd; 26 | 27 | run_test($_) for qw( 28 | capture 29 | capture_scalar 30 | capture_stdout 31 | capture_stderr 32 | capture_merged 33 | ); 34 | 35 | if ( ! $no_fork ) { 36 | run_test($_) for qw( 37 | tee 38 | tee_scalar 39 | tee_stdout 40 | tee_stderr 41 | tee_merged 42 | ); 43 | } 44 | 45 | is( next_fd, $fd, "no file descriptors leaked" ); 46 | restore_std(qw/stderr/); 47 | 48 | exit 0; 49 | -------------------------------------------------------------------------------- /t/08-stdin-closed.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/save_std restore_std next_fd/; 12 | use Cases qw/run_test/; 13 | 14 | use Config; 15 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 16 | 17 | plan 'no_plan'; 18 | 19 | my $builder = Test::More->builder; 20 | binmode($builder->failure_output, ':utf8') if "$]" >= 5.008; 21 | 22 | # XXX work around a bug in perl; this needs to be called early-ish 23 | # to avoid some sort of filehandle leak when combined with Capture::Tiny 24 | my $qm = quotemeta("\x{263a}"); 25 | 26 | save_std(qw/stdin/); 27 | ok( close STDIN, "closed STDIN" ); 28 | 29 | my $fd = next_fd; 30 | 31 | run_test($_) for qw( 32 | capture 33 | capture_scalar 34 | capture_stdout 35 | capture_stderr 36 | capture_merged 37 | ); 38 | 39 | if ( ! $no_fork ) { 40 | # prior to 5.12, PERL_UNICODE=D causes problems when STDIN is closed 41 | # before capturing. No idea why. Documented as a known issue. 42 | if ( "$]" < 5.012 && ${^UNICODE} & 24 ) { 43 | diag 'Skipping tee() tests because PERL_UNICODE=D not supported'; 44 | } 45 | else { 46 | run_test($_) for qw( 47 | tee 48 | tee_scalar 49 | tee_stdout 50 | tee_stderr 51 | tee_merged 52 | ); 53 | } 54 | } 55 | 56 | if ( "$]" < 5.012 && ${^UNICODE} & 24 ) { 57 | diag 'Skipping leak test because PERL_UNICODE=D not supported'; 58 | } 59 | else { 60 | is( next_fd, $fd, "no file descriptors leaked" ); 61 | } 62 | 63 | restore_std(qw/stdin/); 64 | 65 | exit 0; 66 | -------------------------------------------------------------------------------- /t/09-preserve-exit-code.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/next_fd sig_num/; 12 | use Capture::Tiny qw/capture/; 13 | use Config; 14 | 15 | plan tests => 2; 16 | 17 | my $builder = Test::More->builder; 18 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 19 | 20 | my $fd = next_fd; 21 | 22 | capture { 23 | $? = 42; 24 | }; 25 | is( $?, 42, "\$\? preserved after capture ends" ); 26 | 27 | is( next_fd, $fd, "no file descriptors leaked" ); 28 | 29 | exit 0; 30 | 31 | -------------------------------------------------------------------------------- /t/10-stdout-string.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/save_std restore_std next_fd/; 12 | use Cases qw/run_test/; 13 | 14 | use Config; 15 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 16 | 17 | plan skip_all => "In memory files require Perl 5.8" 18 | if $] < 5.008; 19 | 20 | plan 'no_plan'; 21 | 22 | my $builder = Test::More->builder; 23 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 24 | 25 | save_std(qw/stdout/); 26 | ok( close STDOUT, "closed STDOUT" ); 27 | ok( open( STDOUT, ">", \(my $stdout_buf)), "reopened STDOUT to string" ); 28 | 29 | my $fd = next_fd; 30 | 31 | run_test($_) for qw( 32 | capture 33 | capture_scalar 34 | capture_stdout 35 | capture_stderr 36 | capture_merged 37 | ); 38 | 39 | if ( ! $no_fork ) { 40 | run_test($_) for qw( 41 | tee 42 | tee_scalar 43 | tee_stdout 44 | tee_stderr 45 | tee_merged 46 | ); 47 | } 48 | 49 | is( next_fd, $fd, "no file descriptors leaked" ); 50 | restore_std(qw/stdout/); 51 | 52 | exit 0; 53 | 54 | -------------------------------------------------------------------------------- /t/11-stderr-string.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/save_std restore_std next_fd/; 12 | use Cases qw/run_test/; 13 | 14 | use Config; 15 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 16 | 17 | plan skip_all => "In memory files require Perl 5.8" 18 | if $] < 5.008; 19 | 20 | plan 'no_plan'; 21 | 22 | my $builder = Test::More->builder; 23 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 24 | 25 | save_std(qw/stderr/); 26 | ok( close STDERR, "closed STDERR" ); 27 | ok( open( STDERR, ">", \(my $stderr_buf)), "reopened STDERR to string" ); 28 | 29 | my $fd = next_fd; 30 | 31 | run_test($_) for qw( 32 | capture 33 | capture_scalar 34 | capture_stdout 35 | capture_stderr 36 | capture_merged 37 | ); 38 | 39 | if ( ! $no_fork ) { 40 | run_test($_) for qw( 41 | tee 42 | tee_scalar 43 | tee_stdout 44 | tee_stderr 45 | tee_merged 46 | ); 47 | } 48 | 49 | is( next_fd, $fd, "no file descriptors leaked" ); 50 | restore_std(qw/stderr/); 51 | 52 | exit 0; 53 | -------------------------------------------------------------------------------- /t/12-stdin-string.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/save_std restore_std next_fd/; 12 | use Cases qw/run_test/; 13 | 14 | use Config; 15 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 16 | 17 | plan skip_all => "In memory files require Perl 5.8" 18 | if $] < 5.008; 19 | 20 | plan 'no_plan'; 21 | 22 | my $builder = Test::More->builder; 23 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 24 | 25 | #--------------------------------------------------------------------------# 26 | 27 | # pre-load PerlIO::scalar to avoid it opening on FD 0; c.f. 28 | # http://www.nntp.perl.org/group/perl.perl5.porters/2008/07/msg138898.html 29 | require PerlIO::scalar; 30 | 31 | save_std(qw/stdin/); 32 | ok( close STDIN, "closed STDIN" ); 33 | ok( open( STDIN, "<", \(my $stdin_buf)), "reopened STDIN to string" ); 34 | 35 | my $fd = next_fd; 36 | 37 | run_test($_) for qw( 38 | capture 39 | capture_scalar 40 | capture_stdout 41 | capture_stderr 42 | capture_merged 43 | ); 44 | 45 | if ( ! $no_fork ) { 46 | run_test($_) for qw( 47 | tee 48 | tee_scalar 49 | tee_stdout 50 | tee_stderr 51 | tee_merged 52 | ); 53 | } 54 | 55 | is( next_fd, $fd, "no file descriptors leaked" ); 56 | restore_std(qw/stdin/); 57 | 58 | exit 0; 59 | 60 | -------------------------------------------------------------------------------- /t/13-stdout-tied.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/save_std restore_std next_fd/; 12 | use Cases qw/run_test/; 13 | use TieLC; 14 | 15 | use Config; 16 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 17 | 18 | plan skip_all => "capture needs Perl 5.8 for tied STDOUT" 19 | if $] < 5.008; 20 | 21 | plan 'no_plan'; 22 | 23 | my $builder = Test::More->builder; 24 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 25 | binmode($builder->todo_output, ':utf8') if $] >= 5.008; 26 | 27 | save_std(qw/stdout/); 28 | tie *STDOUT, 'TieLC', ">&=STDOUT"; 29 | my $orig_tie = tied *STDOUT; 30 | ok( $orig_tie, "STDOUT is tied" ); 31 | 32 | my $fd = next_fd; 33 | 34 | run_test($_) for qw( 35 | capture 36 | capture_scalar 37 | capture_stdout 38 | capture_stderr 39 | capture_merged 40 | ); 41 | 42 | if ( ! $no_fork ) { 43 | run_test($_) for qw( 44 | tee 45 | tee_scalar 46 | tee_stdout 47 | tee_stderr 48 | tee_merged 49 | ); 50 | } 51 | 52 | is( next_fd, $fd, "no file descriptors leaked" ); 53 | is( tied *STDOUT, $orig_tie, "STDOUT is still tied" ); 54 | restore_std(qw/stdout/); 55 | 56 | exit 0; 57 | -------------------------------------------------------------------------------- /t/14-stderr-tied.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/save_std restore_std next_fd/; 12 | use Cases qw/run_test/; 13 | use TieLC; 14 | 15 | use Config; 16 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 17 | 18 | plan skip_all => "capture needs Perl 5.8 for tied STDERR" 19 | if $] < 5.008; 20 | 21 | plan 'no_plan'; 22 | 23 | my $builder = Test::More->builder; 24 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 25 | binmode($builder->todo_output, ':utf8') if $] >= 5.008; 26 | 27 | save_std(qw/stderr/); 28 | tie *STDERR, 'TieLC', ">&=STDERR"; 29 | my $orig_tie = tied *STDERR; 30 | ok( $orig_tie, "STDERR is tied" ); 31 | 32 | my $fd = next_fd; 33 | 34 | run_test($_) for qw( 35 | capture 36 | capture_scalar 37 | capture_stdout 38 | capture_stderr 39 | capture_merged 40 | ); 41 | 42 | if ( ! $no_fork ) { 43 | run_test($_) for qw( 44 | tee 45 | tee_scalar 46 | tee_stdout 47 | tee_stderr 48 | tee_merged 49 | ); 50 | } 51 | 52 | is( next_fd, $fd, "no file descriptors leaked" ); 53 | is( tied *STDERR, $orig_tie, "STDERR is still tied" ); 54 | restore_std(qw/stderr/); 55 | 56 | exit 0; 57 | -------------------------------------------------------------------------------- /t/15-stdin-tied.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/save_std restore_std next_fd/; 12 | use Cases qw/run_test/; 13 | use TieLC; 14 | 15 | use Config; 16 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 17 | 18 | plan skip_all => "capture needs Perl 5.8 for tied STDERR" 19 | if $] < 5.008; 20 | 21 | #plan skip_all => "not supported on Windows yet" 22 | # if $^O eq 'MSWin32'; 23 | 24 | plan 'no_plan'; 25 | 26 | my $builder = Test::More->builder; 27 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 28 | 29 | save_std(qw/stdin/); 30 | tie *STDIN, 'TieLC', "<&=STDIN"; 31 | my $orig_tie = tied *STDIN; 32 | ok( $orig_tie, "STDIN is tied" ); 33 | 34 | my $fd = next_fd; 35 | 36 | run_test($_) for qw( 37 | capture 38 | capture_scalar 39 | capture_stdout 40 | capture_stderr 41 | capture_merged 42 | ); 43 | 44 | if ( ! $no_fork ) { 45 | run_test($_) for qw( 46 | tee 47 | tee_scalar 48 | tee_stdout 49 | tee_stderr 50 | tee_merged 51 | ); 52 | } 53 | 54 | is( next_fd, $fd, "no file descriptors leaked" ); 55 | is( tied *STDIN, $orig_tie, "STDIN is still tied" ); 56 | restore_std(qw/stdin/); 57 | 58 | exit 0; 59 | -------------------------------------------------------------------------------- /t/16-catch-errors.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/next_fd sig_num/; 12 | use Capture::Tiny qw/capture tee/; 13 | use Config; 14 | 15 | plan tests => 5; 16 | 17 | local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # no timeouts 18 | 19 | my $builder = Test::More->builder; 20 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 21 | 22 | my $fd = next_fd; 23 | $@ = "initial error"; 24 | my ($out, $err) = capture { print "foo\n" }; 25 | is( $@, 'initial error', "Initial \$\@ not lost during capture" ); 26 | 27 | 28 | ($out, $err) = capture { 29 | eval { 30 | tee { 31 | local $|=1; 32 | print STDOUT "foo\n"; 33 | print STDERR "bar\n"; 34 | die "Fatal error in capture\n"; 35 | } 36 | }; 37 | }; 38 | my $error = $@; 39 | 40 | is( $error, "Fatal error in capture\n", "\$\@ preserved after capture" ); 41 | is( $out, "foo\n", "STDOUT still captured" ); 42 | is( $err, "bar\n", "STDOUT still captured" ); 43 | 44 | is( next_fd, $fd, "no file descriptors leaked" ); 45 | 46 | exit 0; 47 | 48 | -------------------------------------------------------------------------------- /t/17-pass-results.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use IO::Handle; 12 | use Utils qw/next_fd sig_num/; 13 | use Capture::Tiny ':all'; 14 | use Config; 15 | 16 | plan tests => 12; 17 | 18 | local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # no timeouts 19 | 20 | my $builder = Test::More->builder; 21 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 22 | 23 | my $fd = next_fd; 24 | my ($out, $err, $res, @res); 25 | 26 | #--------------------------------------------------------------------------# 27 | # capture to array 28 | #--------------------------------------------------------------------------# 29 | 30 | ($out, $err, @res) = capture { 31 | print STDOUT "foo\n"; 32 | print STDERR "bar\n"; 33 | return qw/one two three/; 34 | }; 35 | 36 | is( $out, "foo\n", "capture -> STDOUT captured" ); 37 | is( $err, "bar\n", "capture -> STDERR captured" ); 38 | is_deeply( \@res, [qw/one two three/], "return values -> array" ); 39 | 40 | #--------------------------------------------------------------------------# 41 | # capture to scalar 42 | #--------------------------------------------------------------------------# 43 | 44 | ($out, $err, $res) = capture { 45 | print STDOUT "baz\n"; 46 | print STDERR "bam\n"; 47 | return qw/one two three/; 48 | }; 49 | 50 | is( $out, "baz\n", "capture -> STDOUT captured" ); 51 | is( $err, "bam\n", "capture -> STDERR captured" ); 52 | is( $res, "one", "return value -> scalar" ); 53 | 54 | #--------------------------------------------------------------------------# 55 | # capture_stdout to array 56 | #--------------------------------------------------------------------------# 57 | 58 | ($out, @res) = capture_stdout { 59 | print STDOUT "foo\n"; 60 | return qw/one two three/; 61 | }; 62 | 63 | is( $out, "foo\n", "capture_stdout -> STDOUT captured" ); 64 | is_deeply( \@res, [qw/one two three/], "return values -> array" ); 65 | 66 | #--------------------------------------------------------------------------# 67 | # capture_merged to array 68 | #--------------------------------------------------------------------------# 69 | 70 | ($out, $res) = capture_merged { 71 | print STDOUT "baz\n"; 72 | print STDERR "bam\n"; 73 | return qw/one two three/; 74 | }; 75 | 76 | like( $out, qr/baz/, "capture_merged -> STDOUT captured" ); 77 | like( $out, qr/bam/, "capture_merged -> STDERR captured" ); 78 | is( $res, "one", "return value -> scalar" ); 79 | 80 | #--------------------------------------------------------------------------# 81 | # finish 82 | #--------------------------------------------------------------------------# 83 | 84 | is( next_fd, $fd, "no file descriptors leaked" ); 85 | 86 | exit 0; 87 | 88 | -------------------------------------------------------------------------------- /t/18-custom-capture.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use IO::Handle; 12 | use IO::File; 13 | use File::Temp qw/tmpnam/; 14 | use Utils qw/next_fd sig_num/; 15 | use Capture::Tiny ':all'; 16 | use Config; 17 | 18 | plan tests => 19; 19 | 20 | local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # no timeouts 21 | 22 | my $builder = Test::More->builder; 23 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 24 | 25 | my $fd = next_fd; 26 | my ($out, $err, $res, @res); 27 | 28 | #--------------------------------------------------------------------------# 29 | # capture to custom IO::File 30 | #--------------------------------------------------------------------------# 31 | 32 | my $temp_out = tmpnam(); 33 | my $temp_err = tmpnam(); 34 | 35 | ok( !-e $temp_out, "Temp out '$temp_out' doesn't exist" ); 36 | ok( !-e $temp_err, "Temp out '$temp_err' doesn't exist" ); 37 | 38 | my $out_fh = IO::File->new($temp_out, "w+"); 39 | my $err_fh = IO::File->new($temp_err, "w+"); 40 | 41 | capture { 42 | print STDOUT "foo\n"; 43 | print STDERR "bar\n"; 44 | } stdout => $out_fh, stderr => $err_fh; 45 | 46 | $out_fh->close; 47 | $err_fh->close; 48 | 49 | is( scalar do {local (@ARGV,$/) = $temp_out; <>} , "foo\n", 50 | "captured STDOUT to custom handle (IO::File)" 51 | ); 52 | is( scalar do {local (@ARGV,$/) = $temp_err; <>} , "bar\n", 53 | "captured STDERR to custom handle (IO::File)" 54 | ); 55 | 56 | unlink $_ for $temp_out, $temp_err; 57 | 58 | #--------------------------------------------------------------------------# 59 | # capture to GLOB handle 60 | #--------------------------------------------------------------------------# 61 | 62 | $temp_out = tmpnam(); 63 | $temp_err = tmpnam(); 64 | 65 | ok( !-e $temp_out, "Temp out '$temp_out' doesn't exist" ); 66 | ok( !-e $temp_err, "Temp out '$temp_err' doesn't exist" ); 67 | 68 | open $out_fh, "+>", $temp_out; 69 | open $err_fh, "+>", $temp_err; 70 | 71 | capture { 72 | print STDOUT "foo\n"; 73 | print STDERR "bar\n"; 74 | } stdout => $out_fh, stderr => $err_fh; 75 | 76 | $out_fh->close; 77 | $err_fh->close; 78 | 79 | is( scalar do {local (@ARGV,$/) = $temp_out; <>} , "foo\n", 80 | "captured STDOUT to custom handle (GLOB)" 81 | ); 82 | is( scalar do {local (@ARGV,$/) = $temp_err; <>} , "bar\n", 83 | "captured STDERR to custom handle (GLOB)" 84 | ); 85 | 86 | unlink $_ for $temp_out, $temp_err; 87 | 88 | #--------------------------------------------------------------------------# 89 | # append to custom IO::File 90 | #--------------------------------------------------------------------------# 91 | 92 | $temp_out = tmpnam(); 93 | $temp_err = tmpnam(); 94 | 95 | ok( !-e $temp_out, "Temp out '$temp_out' doesn't exist" ); 96 | ok( !-e $temp_err, "Temp out '$temp_err' doesn't exist" ); 97 | 98 | $out_fh = IO::File->new($temp_out, "w+"); 99 | $err_fh = IO::File->new($temp_err, "w+"); 100 | 101 | $out_fh->autoflush(1); 102 | $err_fh->autoflush(1); 103 | 104 | print $out_fh "Shouldn't see this in capture\n"; 105 | print $err_fh "Shouldn't see this in capture\n"; 106 | 107 | my ($got_out, $got_err) = capture { 108 | print STDOUT "foo\n"; 109 | print STDERR "bar\n"; 110 | } stdout => $out_fh, stderr => $err_fh; 111 | 112 | $out_fh->close; 113 | $err_fh->close; 114 | 115 | is( $got_out, "foo\n", 116 | "captured appended STDOUT to custom handle" 117 | ); 118 | is( $got_err, "bar\n", 119 | "captured appended STDERR to custom handle" 120 | ); 121 | 122 | unlink $_ for $temp_out, $temp_err; 123 | 124 | #--------------------------------------------------------------------------# 125 | # repeated append to custom IO::File with no output 126 | #--------------------------------------------------------------------------# 127 | 128 | $temp_out = tmpnam(); 129 | $temp_err = tmpnam(); 130 | 131 | ok( !-e $temp_out, "Temp out '$temp_out' doesn't exist" ); 132 | ok( !-e $temp_err, "Temp out '$temp_err' doesn't exist" ); 133 | 134 | $out_fh = IO::File->new($temp_out, "a+"); 135 | $err_fh = IO::File->new($temp_err, "a+"); 136 | 137 | ($got_out, $got_err) = capture { 138 | my $i = 0; $i++ for 1 .. 10; # no output, just busywork 139 | } stdout => $out_fh, stderr => $err_fh; 140 | 141 | is( $got_out, "", 142 | "Try 1: captured empty appended STDOUT to custom handle" 143 | ); 144 | is( $got_err, "", 145 | "Try 1: captured empty appended STDERR to custom handle" 146 | ); 147 | 148 | ($got_out, $got_err) = capture { 149 | my $i = 0; $i++ for 1 .. 10; # no output, just busywork 150 | } stdout => $out_fh, stderr => $err_fh; 151 | 152 | is( $got_out, "", 153 | "Try 2: captured empty appended STDOUT to custom handle" 154 | ); 155 | is( $got_err, "", 156 | "Try 2: captured empty appended STDERR to custom handle" 157 | ); 158 | 159 | unlink $_ for $temp_out, $temp_err; 160 | 161 | #--------------------------------------------------------------------------# 162 | # finish 163 | #--------------------------------------------------------------------------# 164 | 165 | close ARGV; # opened by reading from <> 166 | is( next_fd, $fd, "no file descriptors leaked" ); 167 | 168 | exit 0; 169 | 170 | -------------------------------------------------------------------------------- /t/19-relayering.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/next_fd sig_num/; 12 | use Capture::Tiny ':all'; 13 | 14 | unless ( PerlIO->can('get_layers') ) { 15 | plan skip_all => "Requires PerlIO::getlayers"; 16 | } 17 | 18 | plan 'no_plan'; 19 | 20 | local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # no timeouts 21 | 22 | my $builder = Test::More->builder; 23 | binmode( $builder->failure_output, ':utf8' ) if $] >= 5.008; 24 | 25 | my $fd = next_fd; 26 | my ( $out, $err, $res, @res, %before, %inner, %outer ); 27 | 28 | sub _set_layers { 29 | my ($fh, $new_layers) = @_; 30 | # eliminate pseudo-layers 31 | binmode( $fh, ":raw" ) or die "can't binmode $fh"; 32 | # strip off real layers until only :unix is left 33 | while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) { 34 | binmode( $fh, ":pop" ) or die "can't binmode $fh"; 35 | } 36 | binmode($fh, $new_layers); 37 | } 38 | 39 | sub _get_layers { 40 | return ( 41 | stdout => [ PerlIO::get_layers( *STDOUT, output => 1 ) ], 42 | stderr => [ PerlIO::get_layers( *STDERR, output => 1 ) ], 43 | ); 44 | } 45 | 46 | sub _cmp_layers { 47 | local $Test::Builder::Level = $Test::Builder::Level + 1; 48 | my ($got, $exp, $label) = @_; 49 | 50 | ($got, $exp) = map { ":" . join(":", @$_) } $got, $exp; 51 | is( $got, $exp, $label ); 52 | } 53 | 54 | #--------------------------------------------------------------------------# 55 | # relayer should duplicate layers 56 | #--------------------------------------------------------------------------# 57 | 58 | _set_layers( \*STDOUT, ":unix:encoding(UTF-8):encoding(UTF-8):crlf" ); 59 | _set_layers( \*STDERR, ":unix:encoding(UTF-8):encoding(UTF-8):crlf" ); 60 | 61 | %before = _get_layers(); 62 | 63 | ( $out, $err, @res ) = capture { 64 | %inner = _get_layers(); 65 | print STDOUT "foo\n"; 66 | print STDERR "bar\n"; 67 | }; 68 | 69 | %outer = _get_layers(); 70 | 71 | _cmp_layers( $inner{$_}, $before{$_}, "$_: layers inside capture match previous" ) 72 | for qw/stdout stderr/; 73 | _cmp_layers( $outer{$_}, $before{$_}, "$_: layers after capture match previous" ) 74 | for qw/stdout stderr/; 75 | 76 | #--------------------------------------------------------------------------# 77 | # finish 78 | #--------------------------------------------------------------------------# 79 | 80 | is( next_fd, $fd, "no file descriptors leaked" ); 81 | 82 | exit 0; 83 | # vim: set ts=4 sts=4 sw=4 et tw=75: 84 | -------------------------------------------------------------------------------- /t/20-stdout-badtie.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/save_std restore_std next_fd/; 12 | use Cases qw/run_test/; 13 | use TieEvil; 14 | 15 | use Config; 16 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 17 | 18 | plan skip_all => "capture needs Perl 5.8 for tied STDOUT" 19 | if $] < 5.008; 20 | 21 | plan 'no_plan'; 22 | 23 | my $builder = Test::More->builder; 24 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 25 | binmode($builder->todo_output, ':utf8') if $] >= 5.008; 26 | 27 | tie *STDOUT, 'TieEvil'; 28 | my $orig_tie = tied *STDOUT; 29 | ok( $orig_tie, "STDOUT is tied" ); 30 | 31 | my $fd = next_fd; 32 | 33 | run_test($_, '', 'skip_utf8') for qw( 34 | capture 35 | capture_scalar 36 | capture_stdout 37 | capture_stderr 38 | capture_merged 39 | ); 40 | 41 | if ( ! $no_fork ) { 42 | run_test($_, '', 'skip_utf8') for qw( 43 | tee 44 | tee_scalar 45 | tee_stdout 46 | tee_stderr 47 | tee_merged 48 | ); 49 | } 50 | 51 | is( next_fd, $fd, "no file descriptors leaked" ); 52 | is( tied *STDOUT, $orig_tie, "STDOUT is still tied" ); 53 | 54 | exit 0; 55 | -------------------------------------------------------------------------------- /t/21-stderr-badtie.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/save_std restore_std next_fd/; 12 | use Cases qw/run_test/; 13 | use TieEvil; 14 | 15 | use Config; 16 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 17 | 18 | plan skip_all => "capture needs Perl 5.8 for tied STDERR" 19 | if $] < 5.008; 20 | 21 | plan 'no_plan'; 22 | 23 | my $builder = Test::More->builder; 24 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 25 | binmode($builder->todo_output, ':utf8') if $] >= 5.008; 26 | 27 | tie *STDERR, 'TieEvil'; 28 | my $orig_tie = tied *STDERR; 29 | ok( $orig_tie, "STDERR is tied" ); 30 | 31 | my $fd = next_fd; 32 | 33 | run_test($_, '', 'skip_utf8') for qw( 34 | capture 35 | capture_scalar 36 | capture_stdout 37 | capture_stderr 38 | capture_merged 39 | ); 40 | 41 | if ( ! $no_fork ) { 42 | run_test($_, '', 'skip_utf8') for qw( 43 | tee 44 | tee_scalar 45 | tee_stdout 46 | tee_stderr 47 | tee_merged 48 | ); 49 | } 50 | 51 | is( next_fd, $fd, "no file descriptors leaked" ); 52 | is( tied *STDERR, $orig_tie, "STDERR is still tied" ); 53 | 54 | exit 0; 55 | -------------------------------------------------------------------------------- /t/22-stdin-badtie.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/save_std restore_std next_fd/; 12 | use Cases qw/run_test/; 13 | use TieEvil; 14 | 15 | use Config; 16 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 17 | 18 | plan skip_all => "capture needs Perl 5.8 for tied STDIN" 19 | if $] < 5.008; 20 | 21 | plan 'no_plan'; 22 | 23 | my $builder = Test::More->builder; 24 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 25 | binmode($builder->todo_output, ':utf8') if $] >= 5.008; 26 | 27 | tie *STDIN, 'TieEvil'; 28 | my $orig_tie = tied *STDIN; 29 | ok( $orig_tie, "STDIN is tied" ); 30 | 31 | my $fd = next_fd; 32 | 33 | run_test($_, '', 'skip_utf8') for qw( 34 | capture 35 | capture_scalar 36 | capture_stdout 37 | capture_stderr 38 | capture_merged 39 | ); 40 | 41 | if ( ! $no_fork ) { 42 | run_test($_, '', 'skip_utf8') for qw( 43 | tee 44 | tee_scalar 45 | tee_stdout 46 | tee_stderr 47 | tee_merged 48 | ); 49 | } 50 | 51 | is( next_fd, $fd, "no file descriptors leaked" ); 52 | is( tied *STDIN, $orig_tie, "STDIN is still tied" ); 53 | 54 | exit 0; 55 | -------------------------------------------------------------------------------- /t/23-all-tied.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/save_std restore_std next_fd/; 12 | use Cases qw/run_test/; 13 | use TieLC; 14 | 15 | use Config; 16 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 17 | 18 | plan skip_all => "capture needs Perl 5.8 for tied STDOUT" 19 | if $] < 5.008; 20 | 21 | plan 'no_plan'; 22 | 23 | my $builder = Test::More->builder; 24 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 25 | binmode($builder->todo_output, ':utf8') if $] >= 5.008; 26 | 27 | save_std(qw/stdout stderr stdin/); 28 | tie *STDOUT, 'TieLC', ">&=STDOUT"; 29 | my $out_tie = tied *STDOUT; 30 | ok( $out_tie, "STDOUT is tied" ); 31 | tie *STDERR, 'TieLC', ">&=STDERR"; 32 | my $err_tie = tied *STDERR; 33 | ok( $err_tie, "STDERR is tied" ); 34 | tie *STDIN, 'TieLC', "<&=STDIN"; 35 | my $in_tie = tied *STDIN; 36 | ok( $in_tie, "STDIN is tied" ); 37 | 38 | my $fd = next_fd; 39 | 40 | run_test($_) for qw( 41 | capture 42 | capture_scalar 43 | capture_stdout 44 | capture_stderr 45 | capture_merged 46 | ); 47 | 48 | if ( ! $no_fork ) { 49 | run_test($_) for qw( 50 | tee 51 | tee_scalar 52 | tee_stdout 53 | tee_stderr 54 | tee_merged 55 | ); 56 | } 57 | 58 | is( next_fd, $fd, "no file descriptors leaked" ); 59 | is( tied *STDOUT, $out_tie, "STDOUT is still tied" ); 60 | is( tied *STDERR, $err_tie, "STDERR is still tied" ); 61 | is( tied *STDIN, $in_tie, "STDIN is still tied" ); 62 | restore_std(qw/stdout stderr stdin/); 63 | 64 | exit 0; 65 | -------------------------------------------------------------------------------- /t/24-all-badtied.t: -------------------------------------------------------------------------------- 1 | # Copyright (c) 2009 by David Golden. All rights reserved. 2 | # Licensed under Apache License, Version 2.0 (the "License"). 3 | # You may not use this file except in compliance with the License. 4 | # A copy of the License was distributed with this file or you may obtain a 5 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | use lib 't/lib'; 11 | use Utils qw/save_std restore_std next_fd/; 12 | use Cases qw/run_test/; 13 | use TieEvil; 14 | 15 | use Config; 16 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 17 | 18 | plan skip_all => "capture needs Perl 5.8 for tied STDIN" 19 | if $] < 5.008; 20 | 21 | plan 'no_plan'; 22 | 23 | my $builder = Test::More->builder; 24 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 25 | binmode($builder->todo_output, ':utf8') if $] >= 5.008; 26 | 27 | tie *STDIN, 'TieEvil'; 28 | my $in_tie = tied *STDIN; 29 | ok( $in_tie, "STDIN is tied" ); 30 | 31 | tie *STDOUT, 'TieEvil'; 32 | my $out_tie = tied *STDOUT; 33 | ok( $out_tie, "STDIN is tied" ); 34 | 35 | tie *STDERR, 'TieEvil'; 36 | my $err_tie = tied *STDERR; 37 | ok( $err_tie, "STDIN is tied" ); 38 | 39 | my $fd = next_fd; 40 | 41 | run_test($_, '', 'skip_utf8') for qw( 42 | capture 43 | capture_scalar 44 | capture_stdout 45 | capture_stderr 46 | capture_merged 47 | ); 48 | 49 | if ( ! $no_fork ) { 50 | run_test($_, '', 'skip_utf8') for qw( 51 | tee 52 | tee_scalar 53 | tee_stdout 54 | tee_stderr 55 | tee_merged 56 | ); 57 | } 58 | 59 | is( next_fd, $fd, "no file descriptors leaked" ); 60 | is( tied *STDIN, $in_tie, "STDIN is still tied" ); 61 | is( tied *STDOUT, $out_tie, "STDOUT is still tied" ); 62 | is( tied *STDERR, $err_tie, "STDERR is still tied" ); 63 | 64 | exit 0; 65 | -------------------------------------------------------------------------------- /t/25-cap-fork.t: -------------------------------------------------------------------------------- 1 | # By Yary Hluchan with portions copied from David Golden 2 | # Copyright (c) 2015 assigned by Yary Hluchan to David Golden. 3 | # All rights reserved. 4 | # Licensed under Apache License, Version 2.0 (the "License"). 5 | # You may not use this file except in compliance with the License. 6 | # A copy of the License was distributed with this file or you may obtain a 7 | # copy of the License from http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | use strict; 10 | use warnings; 11 | use Test::More; 12 | use lib 't/lib'; 13 | use Utils qw/next_fd/; 14 | use Capture::Tiny 'capture'; 15 | 16 | use Config; 17 | my $no_fork = $^O ne 'MSWin32' && ! $Config{d_fork}; 18 | if ( $no_fork ) { 19 | plan skip_all => 'tee() requires fork'; 20 | } 21 | else { 22 | plan 'no_plan'; 23 | } 24 | 25 | my $builder = Test::More->builder; 26 | binmode($builder->failure_output, ':utf8') if $] >= 5.008; 27 | 28 | my $fd = next_fd; 29 | 30 | 31 | my ($stdout, $stderr, @result) = capture { 32 | if (!defined(my $child = fork)) { die "fork() failed" } 33 | elsif ($child == 0) { 34 | print "Happiness"; 35 | print STDERR "Certainty\n"; 36 | exit; 37 | } 38 | else { 39 | wait; 40 | print ", a parent-ly\n"; 41 | } 42 | return qw(a b c); 43 | }; 44 | 45 | is ( $stdout, "Happiness, a parent-ly\n", "got stdout"); 46 | is ( $stderr, "Certainty\n", "got stderr"); 47 | is ( "@result", "a b c" , "got result"); 48 | is ( next_fd, $fd, "no file descriptors leaked" ); 49 | 50 | exit 0; 51 | -------------------------------------------------------------------------------- /t/lib/Cases.pm: -------------------------------------------------------------------------------- 1 | package Cases; 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use Capture::Tiny ':all'; 6 | 7 | require Exporter; 8 | our @ISA = 'Exporter'; 9 | our @EXPORT_OK = qw( 10 | run_test 11 | ); 12 | 13 | my $locale_ok = eval { 14 | my $err = capture_stderr { system($^X, '-we', 1) }; 15 | $err !~ /setting locale failed/i; 16 | }; 17 | 18 | my $have_diff = eval { 19 | require Test::Differences; 20 | Test::Differences->import; 21 | $Test::Differences::VERSION < 0.60; # 0.60+ is causing strange failures 22 | }; 23 | 24 | sub _is_or_diff { 25 | my ($g,$e,$l) = @_; 26 | if ( $have_diff ) { eq_or_diff( $g, $e, $l ); } 27 | else { is( $g, $e, $l ); } 28 | } 29 | 30 | sub _binmode { 31 | my $text = shift; 32 | return $text eq 'unicode' ? 'binmode(STDOUT,q{:utf8}); binmode(STDERR,q{:utf8});' : ''; 33 | } 34 | 35 | sub _set_utf8 { 36 | my $t = shift; 37 | return unless $t eq 'unicode'; 38 | my %seen; 39 | my @orig_layers = ( 40 | [ grep {$_ ne 'unix' and $_ ne 'perlio' and $seen{stdout}{$_}++} PerlIO::get_layers(\*STDOUT) ], 41 | [ grep {$_ ne 'unix' and $_ ne 'perlio' and $seen{stderr}{$_}++} PerlIO::get_layers(\*STDERR) ], 42 | ); 43 | binmode(STDOUT, ":utf8") if fileno(STDOUT); 44 | binmode(STDERR, ":utf8") if fileno(STDERR); 45 | return @orig_layers; 46 | } 47 | 48 | sub _restore_layers { 49 | my ($t, @orig_layers) = @_; 50 | return unless $t eq 'unicode'; 51 | binmode(STDOUT, join( ":", "", "raw", @{$orig_layers[0]})) if fileno(STDOUT); 52 | binmode(STDERR, join( ":", "", "raw", @{$orig_layers[1]})) if fileno(STDERR); 53 | } 54 | 55 | #--------------------------------------------------------------------------# 56 | 57 | my %texts = ( 58 | short => 'Hello World', 59 | multiline => 'First line\nSecond line\n', 60 | ( "$]" < 5.008 ? () : ( unicode => 'Hi! \x{263a}\n') ), 61 | ); 62 | 63 | #--------------------------------------------------------------------------# 64 | # fcn($perl_code_string) => execute the perl in current process or subprocess 65 | #--------------------------------------------------------------------------# 66 | 67 | my %methods = ( 68 | perl => sub { eval $_[0] }, 69 | sys => sub { system($^X, '-e', $_[0]) }, 70 | ); 71 | 72 | #--------------------------------------------------------------------------# 73 | 74 | my %channels = ( 75 | stdout => { 76 | output => sub { _binmode($_[0]) . "print STDOUT qq{STDOUT:$texts{$_[0]}}" }, 77 | expect => sub { eval "qq{STDOUT:$texts{$_[0]}}", "" }, 78 | }, 79 | stderr => { 80 | output => sub { _binmode($_[0]) . "print STDERR qq{STDERR:$texts{$_[0]}}" }, 81 | expect => sub { "", eval "qq{STDERR:$texts{$_[0]}}" }, 82 | }, 83 | both => { 84 | output => sub { _binmode($_[0]) . "print STDOUT qq{STDOUT:$texts{$_[0]}}; print STDERR qq{STDERR:$texts{$_[0]}}" }, 85 | expect => sub { eval "qq{STDOUT:$texts{$_[0]}}", eval "qq{STDERR:$texts{$_[0]}}" }, 86 | }, 87 | empty => { 88 | output => sub { _binmode($_[0]) . "print STDOUT qq{}; print STDERR qq{}" }, 89 | expect => sub { "", "" }, 90 | }, 91 | nooutput=> { 92 | output => sub { _binmode($_[0]) }, 93 | expect => sub { "", "" }, 94 | }, 95 | ); 96 | 97 | #--------------------------------------------------------------------------# 98 | 99 | my %tests = ( 100 | capture => { 101 | cnt => 2, 102 | test => sub { 103 | my ($m, $c, $t, $l) = @_; 104 | my ($got_out, $got_err) = capture { 105 | $methods{$m}->( $channels{$c}{output}->($t) ); 106 | }; 107 | my @expected = $channels{$c}{expect}->($t); 108 | _is_or_diff( $got_out, $expected[0], "$l|$m|$c|$t - got STDOUT" ); 109 | _is_or_diff( $got_err, $expected[1], "$l|$m|$c|$t - got STDERR" ); 110 | }, 111 | }, 112 | capture_scalar => { 113 | cnt => 1, 114 | test => sub { 115 | my ($m, $c, $t, $l) = @_; 116 | my $got_out = capture { 117 | $methods{$m}->( $channels{$c}{output}->($t) ); 118 | }; 119 | my @expected = $channels{$c}{expect}->($t); 120 | _is_or_diff( $got_out, $expected[0], "$l|$m|$c|$t - got STDOUT" ); 121 | }, 122 | }, 123 | capture_stdout => { 124 | cnt => 3, 125 | test => sub { 126 | my ($m, $c, $t, $l) = @_; 127 | my ($inner_out, $inner_err); 128 | my ($outer_out, $outer_err) = capture { 129 | $inner_out = capture_stdout { 130 | $methods{$m}->( $channels{$c}{output}->($t) ); 131 | }; 132 | }; 133 | my @expected = $channels{$c}{expect}->($t); 134 | _is_or_diff( $inner_out, $expected[0], "$l|$m|$c|$t - inner STDOUT" ); 135 | _is_or_diff( $outer_out, "", "$l|$m|$c|$t - outer STDOUT" ); 136 | _is_or_diff( $outer_err, $expected[1], "$l|$m|$c|$t - outer STDERR" ); 137 | }, 138 | }, 139 | capture_stderr => { 140 | cnt => 3, 141 | test => sub { 142 | my ($m, $c, $t, $l) = @_; 143 | my ($inner_out, $inner_err); 144 | my ($outer_out, $outer_err) = capture { 145 | $inner_err = capture_stderr { 146 | $methods{$m}->( $channels{$c}{output}->($t) ); 147 | }; 148 | }; 149 | my @expected = $channels{$c}{expect}->($t); 150 | _is_or_diff( $inner_err, $expected[1], "$l|$m|$c|$t - inner STDERR" ); 151 | _is_or_diff( $outer_out, $expected[0], "$l|$m|$c|$t - outer STDOUT" ); 152 | _is_or_diff( $outer_err, "", "$l|$m|$c|$t - outer STDERR" ); 153 | }, 154 | }, 155 | capture_merged => { 156 | cnt => 2, 157 | test => sub { 158 | my ($m, $c, $t, $l) = @_; 159 | my $got_out = capture_merged { 160 | $methods{$m}->( $channels{$c}{output}->($t) ); 161 | }; 162 | my @expected = $channels{$c}{expect}->($t); 163 | like( $got_out, qr/\Q$expected[0]\E/, "$l|$m|$c|$t - got STDOUT" ); 164 | like( $got_out, qr/\Q$expected[1]\E/, "$l|$m|$c|$t - got STDERR" ); 165 | }, 166 | }, 167 | tee => { 168 | cnt => 4, 169 | test => sub { 170 | my ($m, $c, $t, $l) = @_; 171 | my ($got_out, $got_err); 172 | my ($tee_out, $tee_err) = capture { 173 | ($got_out, $got_err) = tee { 174 | $methods{$m}->( $channels{$c}{output}->($t) ); 175 | }; 176 | }; 177 | my @expected = $channels{$c}{expect}->($t); 178 | _is_or_diff( $got_out, $expected[0], "$l|$m|$c|$t - got STDOUT" ); 179 | _is_or_diff( $tee_out, $expected[0], "$l|$m|$c|$t - tee STDOUT" ); 180 | _is_or_diff( $got_err, $expected[1], "$l|$m|$c|$t - got STDERR" ); 181 | _is_or_diff( $tee_err, $expected[1], "$l|$m|$c|$t - tee STDERR" ); 182 | } 183 | }, 184 | tee_scalar => { 185 | cnt => 3, 186 | test => sub { 187 | my ($m, $c, $t, $l) = @_; 188 | my ($got_out, $got_err); 189 | my ($tee_out, $tee_err) = capture { 190 | $got_out = tee { 191 | $methods{$m}->( $channels{$c}{output}->($t) ); 192 | }; 193 | }; 194 | my @expected = $channels{$c}{expect}->($t); 195 | _is_or_diff( $got_out, $expected[0], "$l|$m|$c|$t - got STDOUT" ); 196 | _is_or_diff( $tee_out, $expected[0], "$l|$m|$c|$t - tee STDOUT" ); 197 | _is_or_diff( $tee_err, $expected[1], "$l|$m|$c|$t - tee STDERR" ); 198 | } 199 | }, 200 | tee_stdout => { 201 | cnt => 3, 202 | test => sub { 203 | my ($m, $c, $t, $l) = @_; 204 | my ($inner_out, $inner_err); 205 | my ($tee_out, $tee_err) = capture { 206 | $inner_out = tee_stdout { 207 | $methods{$m}->( $channels{$c}{output}->($t) ); 208 | }; 209 | }; 210 | my @expected = $channels{$c}{expect}->($t); 211 | _is_or_diff( $inner_out, $expected[0], "$l|$m|$c|$t - inner STDOUT" ); 212 | _is_or_diff( $tee_out, $expected[0], "$l|$m|$c|$t - teed STDOUT" ); 213 | _is_or_diff( $tee_err, $expected[1], "$l|$m|$c|$t - unmodified STDERR" ); 214 | } 215 | }, 216 | tee_stderr => { 217 | cnt => 3, 218 | test => sub { 219 | my ($m, $c, $t, $l) = @_; 220 | my ($inner_out, $inner_err); 221 | my ($tee_out, $tee_err) = capture { 222 | $inner_err = tee_stderr { 223 | $methods{$m}->( $channels{$c}{output}->($t) ); 224 | }; 225 | }; 226 | my @expected = $channels{$c}{expect}->($t); 227 | _is_or_diff( $inner_err, $expected[1], "$l|$m|$c|$t - inner STDOUT" ); 228 | _is_or_diff( $tee_out, $expected[0], "$l|$m|$c|$t - unmodified STDOUT" ); 229 | _is_or_diff( $tee_err, $expected[1], "$l|$m|$c|$t - teed STDERR" ); 230 | } 231 | }, 232 | tee_merged => { 233 | cnt => 5, 234 | test => sub { 235 | my ($m, $c, $t, $l) = @_; 236 | my ($got_out, $got_err); 237 | my ($tee_out, $tee_err) = capture { 238 | $got_out = tee_merged { 239 | $methods{$m}->( $channels{$c}{output}->($t) ); 240 | }; 241 | }; 242 | my @expected = $channels{$c}{expect}->($t); 243 | like( $got_out, qr/\Q$expected[0]\E/, "$l|$m|$c|$t - got STDOUT" ); 244 | like( $got_out, qr/\Q$expected[1]\E/, "$l|$m|$c|$t - got STDERR" ); 245 | like( $tee_out, qr/\Q$expected[0]\E/, "$l|$m|$c|$t - tee STDOUT (STDOUT)" ); 246 | like( $tee_out, qr/\Q$expected[1]\E/, "$l|$m|$c|$t - tee STDOUT (STDERR)" ); 247 | _is_or_diff( $tee_err, '', "$l|$m|$c|$t - tee STDERR" ); 248 | } 249 | }, 250 | ); 251 | 252 | #--------------------------------------------------------------------------# 253 | # What I want to be able to do: 254 | # 255 | # test_it( 256 | # input => 'short', 257 | # channels => 'both', 258 | # method => 'perl' 259 | # ) 260 | 261 | sub run_test { 262 | my $test_type = shift or return; 263 | my $todo = shift || ''; 264 | my $skip_utf8 = shift || ''; 265 | local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # don't timeout during testing 266 | for my $m ( keys %methods ) { 267 | if ( ($m eq 'sys' || substr($test_type,0,3) eq 'tee' ) && ! $locale_ok ) { 268 | SKIP: { 269 | skip "Perl could not initialize locale", 1 270 | }; 271 | next; 272 | } 273 | for my $c ( keys %channels ) { 274 | for my $t ( keys %texts ) { 275 | next if $t eq 'unicode' && $skip_utf8; 276 | my @orig_layers = _set_utf8($t); 277 | local $TODO = "not supported on all platforms" 278 | if $t eq $todo; 279 | $tests{$test_type}{test}->($m, $c, $t, $test_type); 280 | _restore_layers($t, @orig_layers); 281 | } 282 | } 283 | } 284 | } 285 | 286 | 1; 287 | -------------------------------------------------------------------------------- /t/lib/TieEvil.pm: -------------------------------------------------------------------------------- 1 | package TieEvil; 2 | # FCGI tied with a scalar ref object, which breaks when you 3 | # call open on it. Emulate that to test the workaround: 4 | use Carp (); 5 | 6 | sub TIEHANDLE 7 | { 8 | my $class = shift; 9 | my $fh = \(my $scalar); # this is evil and broken 10 | return bless $fh,$class; 11 | } 12 | 13 | sub EOF { 0 } 14 | sub TELL { length ${$_[0]} } 15 | sub FILENO { -1 } 16 | sub SEEK { 1 } 17 | sub CLOSE { 1 } 18 | sub BINMODE { 1 } 19 | 20 | sub OPEN { Carp::confess "unimplemented" } 21 | 22 | sub READ { $_[1] = substr(${$_[0]},$_[3],$_[2]) } 23 | sub READLINE { "hello world\n" } 24 | sub GETC { substr(${$_[0]},0,1) } 25 | 26 | sub PRINT { 27 | my ($self, @what) = @_; 28 | my $new = join($\, @what); 29 | $$self .= $new; 30 | return length $new; 31 | } 32 | 33 | sub UNTIE { 1 }; # suppress warnings about references 34 | 35 | 1; 36 | -------------------------------------------------------------------------------- /t/lib/TieLC.pm: -------------------------------------------------------------------------------- 1 | package TieLC; 2 | 3 | sub TIEHANDLE 4 | { 5 | my $class = shift; 6 | my $fh = \do { local *HANDLE}; 7 | bless $fh,$class; 8 | $fh->OPEN(@_) if (@_); 9 | $fh->BINMODE(':utf8'); 10 | return $fh; 11 | } 12 | 13 | sub EOF { eof($_[0]) } 14 | sub TELL { tell($_[0]) } 15 | sub FILENO { fileno($_[0]) } 16 | sub SEEK { seek($_[0],$_[1],$_[2]) } 17 | sub CLOSE { close($_[0]) } 18 | sub BINMODE { binmode($_[0],$_[1]) } 19 | 20 | sub OPEN 21 | { 22 | $_[0]->CLOSE if defined($_[0]->FILENO); 23 | @_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]); 24 | } 25 | 26 | sub READ { read($_[0],$_[1],$_[2]) } 27 | sub READLINE { "hello world\n" } 28 | sub GETC { getc($_[0]) } 29 | 30 | sub WRITE 31 | { 32 | my $fh = $_[0]; 33 | print $fh substr($_[1],0,$_[2]) 34 | } 35 | 36 | sub PRINT { 37 | my ($self, @what) = @_; 38 | my $buf = lc join('', @what); 39 | $self->WRITE($buf, length($buf), 0); 40 | } 41 | 42 | sub UNTIE { 1 }; # suppress warnings about references 43 | 44 | 1; 45 | -------------------------------------------------------------------------------- /t/lib/Utils.pm: -------------------------------------------------------------------------------- 1 | package Utils; 2 | use strict; 3 | use warnings; 4 | use File::Spec; 5 | use Config; 6 | 7 | require Exporter; 8 | our @ISA = 'Exporter'; 9 | our @EXPORT = qw/save_std restore_std next_fd sig_num/; 10 | 11 | sub _open { 12 | open $_[0], $_[1] or die "Error from open( " . join(q{, }, @_) . "): $!"; 13 | } 14 | 15 | my @saved; 16 | sub save_std { 17 | for my $h ( @_ ) { 18 | my $fh; 19 | _open $fh, ($h eq 'stdin' ? "<&" : ">&") . uc $h; 20 | push @saved, $fh; 21 | } 22 | } 23 | 24 | sub restore_std { 25 | for my $h ( @_ ) { 26 | no strict 'refs'; 27 | my $fh = shift @saved; 28 | _open \*{uc $h}, ($h eq 'stdin' ? "<&" : ">&") . fileno( $fh ); 29 | close $fh; 30 | } 31 | } 32 | 33 | sub next_fd { 34 | no warnings 'io'; 35 | open my $fh, ">", File::Spec->devnull; 36 | my $fileno = fileno $fh; 37 | close $fh; 38 | return $fileno; 39 | } 40 | 41 | #--------------------------------------------------------------------------# 42 | 43 | my %sig_num; 44 | my @sig_name; 45 | unless($Config{sig_name} && $Config{sig_num}) { 46 | die "No sigs?"; 47 | } else { 48 | my @names = split ' ', $Config{sig_name}; 49 | @sig_num{@names} = split ' ', $Config{sig_num}; 50 | foreach (@names) { 51 | $sig_name[$sig_num{$_}] ||= $_; 52 | } 53 | } 54 | 55 | sub sig_num { 56 | my $name = shift; 57 | return exists $sig_num{$name} ? $sig_num{$name} : ''; 58 | } 59 | 60 | 1; 61 | --------------------------------------------------------------------------------