|
Packit Service |
44c065 |
use 5.006;
|
|
Packit Service |
44c065 |
use strict;
|
|
Packit Service |
44c065 |
use warnings;
|
|
Packit Service |
44c065 |
package Capture::Tiny;
|
|
Packit Service |
44c065 |
# ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs
|
|
Packit Service |
44c065 |
our $VERSION = '0.46';
|
|
Packit Service |
44c065 |
use Carp ();
|
|
Packit Service |
44c065 |
use Exporter ();
|
|
Packit Service |
44c065 |
use IO::Handle ();
|
|
Packit Service |
44c065 |
use File::Spec ();
|
|
Packit Service |
44c065 |
use File::Temp qw/tempfile tmpnam/;
|
|
Packit Service |
44c065 |
use Scalar::Util qw/reftype blessed/;
|
|
Packit Service |
44c065 |
# Get PerlIO or fake it
|
|
Packit Service |
44c065 |
BEGIN {
|
|
Packit Service |
44c065 |
local $@;
|
|
Packit Service |
44c065 |
eval { require PerlIO; PerlIO->can('get_layers') }
|
|
Packit Service |
44c065 |
or *PerlIO::get_layers = sub { return () };
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
#--------------------------------------------------------------------------#
|
|
Packit Service |
44c065 |
# create API subroutines and export them
|
|
Packit Service |
44c065 |
# [do STDOUT flag, do STDERR flag, do merge flag, do tee flag]
|
|
Packit Service |
44c065 |
#--------------------------------------------------------------------------#
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
my %api = (
|
|
Packit Service |
44c065 |
capture => [1,1,0,0],
|
|
Packit Service |
44c065 |
capture_stdout => [1,0,0,0],
|
|
Packit Service |
44c065 |
capture_stderr => [0,1,0,0],
|
|
Packit Service |
44c065 |
capture_merged => [1,1,1,0],
|
|
Packit Service |
44c065 |
tee => [1,1,0,1],
|
|
Packit Service |
44c065 |
tee_stdout => [1,0,0,1],
|
|
Packit Service |
44c065 |
tee_stderr => [0,1,0,1],
|
|
Packit Service |
44c065 |
tee_merged => [1,1,1,1],
|
|
Packit Service |
44c065 |
);
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
for my $sub ( keys %api ) {
|
|
Packit Service |
44c065 |
my $args = join q{, }, @{$api{$sub}};
|
|
Packit Service |
44c065 |
eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
our @ISA = qw/Exporter/;
|
|
Packit Service |
44c065 |
our @EXPORT_OK = keys %api;
|
|
Packit Service |
44c065 |
our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
#--------------------------------------------------------------------------#
|
|
Packit Service |
44c065 |
# constants and fixtures
|
|
Packit Service |
44c065 |
#--------------------------------------------------------------------------#
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
my $IS_WIN32 = $^O eq 'MSWin32';
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
##our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG};
|
|
Packit Service |
44c065 |
##
|
|
Packit Service |
44c065 |
##my $DEBUGFH;
|
|
Packit Service |
44c065 |
##open $DEBUGFH, "> DEBUG" if $DEBUG;
|
|
Packit Service |
44c065 |
##
|
|
Packit Service |
44c065 |
##*_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0};
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
our $TIMEOUT = 30;
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
#--------------------------------------------------------------------------#
|
|
Packit Service |
44c065 |
# command to tee output -- the argument is a filename that must
|
|
Packit Service |
44c065 |
# be opened to signal that the process is ready to receive input.
|
|
Packit Service |
44c065 |
# This is annoying, but seems to be the best that can be done
|
|
Packit Service |
44c065 |
# as a simple, portable IPC technique
|
|
Packit Service |
44c065 |
#--------------------------------------------------------------------------#
|
|
Packit Service |
44c065 |
my @cmd = ($^X, '-C0', '-e', <<'HERE');
|
|
Packit Service |
44c065 |
use Fcntl;
|
|
Packit Service |
44c065 |
$SIG{HUP}=sub{exit};
|
|
Packit Service |
44c065 |
if ( my $fn=shift ) {
|
|
Packit Service |
44c065 |
sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!;
|
|
Packit Service |
44c065 |
print {$fh} $$;
|
|
Packit Service |
44c065 |
close $fh;
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
my $buf; while (sysread(STDIN, $buf, 2048)) {
|
|
Packit Service |
44c065 |
syswrite(STDOUT, $buf); syswrite(STDERR, $buf);
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
HERE
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
#--------------------------------------------------------------------------#
|
|
Packit Service |
44c065 |
# filehandle manipulation
|
|
Packit Service |
44c065 |
#--------------------------------------------------------------------------#
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
sub _relayer {
|
|
Packit Service |
44c065 |
my ($fh, $apply_layers) = @_;
|
|
Packit Service |
44c065 |
# _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n");
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
# eliminate pseudo-layers
|
|
Packit Service |
44c065 |
binmode( $fh, ":raw" );
|
|
Packit Service |
44c065 |
# strip off real layers until only :unix is left
|
|
Packit Service |
44c065 |
while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
|
|
Packit Service |
44c065 |
binmode( $fh, ":pop" );
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
# apply other layers
|
|
Packit Service |
44c065 |
my @to_apply = @$apply_layers;
|
|
Packit Service |
44c065 |
shift @to_apply; # eliminate initial :unix
|
|
Packit Service |
44c065 |
# _debug("# applying layers (unix @to_apply) to @{[fileno $fh]}\n");
|
|
Packit Service |
44c065 |
binmode($fh, ":" . join(":",@to_apply));
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
sub _name {
|
|
Packit Service |
44c065 |
my $glob = shift;
|
|
Packit Service |
44c065 |
no strict 'refs'; ## no critic
|
|
Packit Service |
44c065 |
return *{$glob}{NAME};
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
sub _open {
|
|
Packit Service |
44c065 |
open $_[0], $_[1] or Carp::confess "Error from open(" . join(q{, }, @_) . "): $!";
|
|
Packit Service |
44c065 |
# _debug( "# open " . join( ", " , map { defined $_ ? _name($_) : 'undef' } @_ ) . " as " . fileno( $_[0] ) . "\n" );
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
sub _close {
|
|
Packit Service |
44c065 |
# _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' ) . " on " . fileno( $_[0] ) . "\n" );
|
|
Packit Service |
44c065 |
close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!";
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
my %dup; # cache this so STDIN stays fd0
|
|
Packit Service |
44c065 |
my %proxy_count;
|
|
Packit Service |
44c065 |
sub _proxy_std {
|
|
Packit Service |
44c065 |
my %proxies;
|
|
Packit Service |
44c065 |
if ( ! defined fileno STDIN ) {
|
|
Packit Service |
44c065 |
$proxy_count{stdin}++;
|
|
Packit Service |
44c065 |
if (defined $dup{stdin}) {
|
|
Packit Service |
44c065 |
_open \*STDIN, "<&=" . fileno($dup{stdin});
|
|
Packit Service |
44c065 |
# _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
else {
|
|
Packit Service |
44c065 |
_open \*STDIN, "<" . File::Spec->devnull;
|
|
Packit Service |
44c065 |
# _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
|
|
Packit Service |
44c065 |
_open $dup{stdin} = IO::Handle->new, "<&=STDIN";
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
$proxies{stdin} = \*STDIN;
|
|
Packit Service |
44c065 |
binmode(STDIN, ':utf8') if $] >= 5.008; ## no critic
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
if ( ! defined fileno STDOUT ) {
|
|
Packit Service |
44c065 |
$proxy_count{stdout}++;
|
|
Packit Service |
44c065 |
if (defined $dup{stdout}) {
|
|
Packit Service |
44c065 |
_open \*STDOUT, ">&=" . fileno($dup{stdout});
|
|
Packit Service |
44c065 |
# _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
else {
|
|
Packit Service |
44c065 |
_open \*STDOUT, ">" . File::Spec->devnull;
|
|
Packit Service |
44c065 |
# _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
|
|
Packit Service |
44c065 |
_open $dup{stdout} = IO::Handle->new, ">&=STDOUT";
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
$proxies{stdout} = \*STDOUT;
|
|
Packit Service |
44c065 |
binmode(STDOUT, ':utf8') if $] >= 5.008; ## no critic
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
if ( ! defined fileno STDERR ) {
|
|
Packit Service |
44c065 |
$proxy_count{stderr}++;
|
|
Packit Service |
44c065 |
if (defined $dup{stderr}) {
|
|
Packit Service |
44c065 |
_open \*STDERR, ">&=" . fileno($dup{stderr});
|
|
Packit Service |
44c065 |
# _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
else {
|
|
Packit Service |
44c065 |
_open \*STDERR, ">" . File::Spec->devnull;
|
|
Packit Service |
44c065 |
# _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
|
|
Packit Service |
44c065 |
_open $dup{stderr} = IO::Handle->new, ">&=STDERR";
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
$proxies{stderr} = \*STDERR;
|
|
Packit Service |
44c065 |
binmode(STDERR, ':utf8') if $] >= 5.008; ## no critic
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
return %proxies;
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
sub _unproxy {
|
|
Packit Service |
44c065 |
my (%proxies) = @_;
|
|
Packit Service |
44c065 |
# _debug( "# unproxying: " . join(" ", keys %proxies) . "\n" );
|
|
Packit Service |
44c065 |
for my $p ( keys %proxies ) {
|
|
Packit Service |
44c065 |
$proxy_count{$p}--;
|
|
Packit Service |
44c065 |
# _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" );
|
|
Packit Service |
44c065 |
if ( ! $proxy_count{$p} ) {
|
|
Packit Service |
44c065 |
_close $proxies{$p};
|
|
Packit Service |
44c065 |
_close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup
|
|
Packit Service |
44c065 |
delete $dup{$p};
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
sub _copy_std {
|
|
Packit Service |
44c065 |
my %handles;
|
|
Packit Service |
44c065 |
for my $h ( qw/stdout stderr stdin/ ) {
|
|
Packit Service |
44c065 |
next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied
|
|
Packit Service |
44c065 |
my $redir = $h eq 'stdin' ? "<&" : ">&";
|
|
Packit Service |
44c065 |
_open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN"
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
return \%handles;
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
# In some cases we open all (prior to forking) and in others we only open
|
|
Packit Service |
44c065 |
# the output handles (setting up redirection)
|
|
Packit Service |
44c065 |
sub _open_std {
|
|
Packit Service |
44c065 |
my ($handles) = @_;
|
|
Packit Service |
44c065 |
_open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin};
|
|
Packit Service |
44c065 |
_open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout};
|
|
Packit Service |
44c065 |
_open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr};
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
#--------------------------------------------------------------------------#
|
|
Packit Service |
44c065 |
# private subs
|
|
Packit Service |
44c065 |
#--------------------------------------------------------------------------#
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
sub _start_tee {
|
|
Packit Service |
44c065 |
my ($which, $stash) = @_; # $which is "stdout" or "stderr"
|
|
Packit Service |
44c065 |
# setup pipes
|
|
Packit Service |
44c065 |
$stash->{$_}{$which} = IO::Handle->new for qw/tee reader/;
|
|
Packit Service |
44c065 |
pipe $stash->{reader}{$which}, $stash->{tee}{$which};
|
|
Packit Service |
44c065 |
# _debug( "# pipe for $which\: " . _name($stash->{tee}{$which}) . " " . fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which}) . " " . fileno( $stash->{reader}{$which}) . "\n" );
|
|
Packit Service |
44c065 |
select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush
|
|
Packit Service |
44c065 |
# setup desired redirection for parent and child
|
|
Packit Service |
44c065 |
$stash->{new}{$which} = $stash->{tee}{$which};
|
|
Packit Service |
44c065 |
$stash->{child}{$which} = {
|
|
Packit Service |
44c065 |
stdin => $stash->{reader}{$which},
|
|
Packit Service |
44c065 |
stdout => $stash->{old}{$which},
|
|
Packit Service |
44c065 |
stderr => $stash->{capture}{$which},
|
|
Packit Service |
44c065 |
};
|
|
Packit Service |
44c065 |
# flag file is used to signal the child is ready
|
|
Packit Service |
44c065 |
$stash->{flag_files}{$which} = scalar tmpnam();
|
|
Packit Service |
44c065 |
# execute @cmd as a separate process
|
|
Packit Service |
44c065 |
if ( $IS_WIN32 ) {
|
|
Packit Service |
44c065 |
my $old_eval_err=$@;
|
|
Packit Service |
44c065 |
undef $@;
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
eval "use Win32API::File qw/GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ ";
|
|
Packit Service |
44c065 |
# _debug( "# Win32API::File loaded\n") unless $@;
|
|
Packit Service |
44c065 |
my $os_fhandle = GetOsFHandle( $stash->{tee}{$which} );
|
|
Packit Service |
44c065 |
# _debug( "# Couldn't get OS handle: " . fileLastError() . "\n") if ! defined $os_fhandle || $os_fhandle == INVALID_HANDLE_VALUE();
|
|
Packit Service |
44c065 |
my $result = SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0);
|
|
Packit Service |
44c065 |
# _debug( $result ? "# set no-inherit flag on $which tee\n" : ("# can't disable tee handle flag inherit: " . fileLastError() . "\n"));
|
|
Packit Service |
44c065 |
_open_std( $stash->{child}{$which} );
|
|
Packit Service |
44c065 |
$stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which});
|
|
Packit Service |
44c065 |
# not restoring std here as it all gets redirected again shortly anyway
|
|
Packit Service |
44c065 |
$@=$old_eval_err;
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
else { # use fork
|
|
Packit Service |
44c065 |
_fork_exec( $which, $stash );
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
sub _fork_exec {
|
|
Packit Service |
44c065 |
my ($which, $stash) = @_; # $which is "stdout" or "stderr"
|
|
Packit Service |
44c065 |
my $pid = fork;
|
|
Packit Service |
44c065 |
if ( not defined $pid ) {
|
|
Packit Service |
44c065 |
Carp::confess "Couldn't fork(): $!";
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
elsif ($pid == 0) { # child
|
|
Packit Service |
44c065 |
# _debug( "# in child process ...\n" );
|
|
Packit Service |
44c065 |
untie *STDIN; untie *STDOUT; untie *STDERR;
|
|
Packit Service |
44c065 |
_close $stash->{tee}{$which};
|
|
Packit Service |
44c065 |
# _debug( "# redirecting handles in child ...\n" );
|
|
Packit Service |
44c065 |
_open_std( $stash->{child}{$which} );
|
|
Packit Service |
44c065 |
# _debug( "# calling exec on command ...\n" );
|
|
Packit Service |
44c065 |
exec @cmd, $stash->{flag_files}{$which};
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
$stash->{pid}{$which} = $pid
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
my $have_usleep = eval "use Time::HiRes 'usleep'; 1";
|
|
Packit Service |
44c065 |
sub _files_exist {
|
|
Packit Service |
44c065 |
return 1 if @_ == grep { -f } @_;
|
|
Packit Service |
44c065 |
Time::HiRes::usleep(1000) if $have_usleep;
|
|
Packit Service |
44c065 |
return 0;
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
sub _wait_for_tees {
|
|
Packit Service |
44c065 |
my ($stash) = @_;
|
|
Packit Service |
44c065 |
my $start = time;
|
|
Packit Service |
44c065 |
my @files = values %{$stash->{flag_files}};
|
|
Packit Service |
44c065 |
my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT}
|
|
Packit Service |
44c065 |
? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT;
|
|
Packit Service |
44c065 |
1 until _files_exist(@files) || ($timeout && (time - $start > $timeout));
|
|
Packit Service |
44c065 |
Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files);
|
|
Packit Service |
44c065 |
unlink $_ for @files;
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
sub _kill_tees {
|
|
Packit Service |
44c065 |
my ($stash) = @_;
|
|
Packit Service |
44c065 |
if ( $IS_WIN32 ) {
|
|
Packit Service |
44c065 |
# _debug( "# closing handles\n");
|
|
Packit Service |
44c065 |
close($_) for values %{ $stash->{tee} };
|
|
Packit Service |
44c065 |
# _debug( "# waiting for subprocesses to finish\n");
|
|
Packit Service |
44c065 |
my $start = time;
|
|
Packit Service |
44c065 |
1 until wait == -1 || (time - $start > 30);
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
else {
|
|
Packit Service |
44c065 |
_close $_ for values %{ $stash->{tee} };
|
|
Packit Service |
44c065 |
waitpid $_, 0 for values %{ $stash->{pid} };
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
sub _slurp {
|
|
Packit Service |
44c065 |
my ($name, $stash) = @_;
|
|
Packit Service |
44c065 |
my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/;
|
|
Packit Service |
44c065 |
# _debug( "# slurping captured $name from " . fileno($fh) . " at pos $pos with layers: @{[PerlIO::get_layers($fh)]}\n");
|
|
Packit Service |
44c065 |
seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n";
|
|
Packit Service |
44c065 |
my $text = do { local $/; scalar readline $fh };
|
|
Packit Service |
44c065 |
return defined($text) ? $text : "";
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
#--------------------------------------------------------------------------#
|
|
Packit Service |
44c065 |
# _capture_tee() -- generic main sub for capturing or teeing
|
|
Packit Service |
44c065 |
#--------------------------------------------------------------------------#
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
sub _capture_tee {
|
|
Packit Service |
44c065 |
# _debug( "# starting _capture_tee with (@_)...\n" );
|
|
Packit Service |
44c065 |
my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_;
|
|
Packit Service |
44c065 |
my %do = ($do_stdout ? (stdout => 1) : (), $do_stderr ? (stderr => 1) : ());
|
|
Packit Service |
44c065 |
Carp::confess("Custom capture options must be given as key/value pairs\n")
|
|
Packit Service |
44c065 |
unless @opts % 2 == 0;
|
|
Packit Service |
44c065 |
my $stash = { capture => { @opts } };
|
|
Packit Service |
44c065 |
for ( keys %{$stash->{capture}} ) {
|
|
Packit Service |
44c065 |
my $fh = $stash->{capture}{$_};
|
|
Packit Service |
44c065 |
Carp::confess "Custom handle for $_ must be seekable\n"
|
|
Packit Service |
44c065 |
unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable"));
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
# save existing filehandles and setup captures
|
|
Packit Service |
44c065 |
local *CT_ORIG_STDIN = *STDIN ;
|
|
Packit Service |
44c065 |
local *CT_ORIG_STDOUT = *STDOUT;
|
|
Packit Service |
44c065 |
local *CT_ORIG_STDERR = *STDERR;
|
|
Packit Service |
44c065 |
# find initial layers
|
|
Packit Service |
44c065 |
my %layers = (
|
|
Packit Service |
44c065 |
stdin => [PerlIO::get_layers(\*STDIN) ],
|
|
Packit Service |
44c065 |
stdout => [PerlIO::get_layers(\*STDOUT, output => 1)],
|
|
Packit Service |
44c065 |
stderr => [PerlIO::get_layers(\*STDERR, output => 1)],
|
|
Packit Service |
44c065 |
);
|
|
Packit Service |
44c065 |
# _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
|
|
Packit Service |
44c065 |
# get layers from underlying glob of tied filehandles if we can
|
|
Packit Service |
44c065 |
# (this only works for things that work like Tie::StdHandle)
|
|
Packit Service |
44c065 |
$layers{stdout} = [PerlIO::get_layers(tied *STDOUT)]
|
|
Packit Service |
44c065 |
if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB');
|
|
Packit Service |
44c065 |
$layers{stderr} = [PerlIO::get_layers(tied *STDERR)]
|
|
Packit Service |
44c065 |
if tied(*STDERR) && (reftype tied *STDERR eq 'GLOB');
|
|
Packit Service |
44c065 |
# _debug( "# tied object corrected layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
|
|
Packit Service |
44c065 |
# bypass scalar filehandles and tied handles
|
|
Packit Service |
44c065 |
# localize scalar STDIN to get a proxy to pick up FD0, then restore later to CT_ORIG_STDIN
|
|
Packit Service |
44c065 |
my %localize;
|
|
Packit Service |
44c065 |
$localize{stdin}++, local(*STDIN)
|
|
Packit Service |
44c065 |
if grep { $_ eq 'scalar' } @{$layers{stdin}};
|
|
Packit Service |
44c065 |
$localize{stdout}++, local(*STDOUT)
|
|
Packit Service |
44c065 |
if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}};
|
|
Packit Service |
44c065 |
$localize{stderr}++, local(*STDERR)
|
|
Packit Service |
44c065 |
if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}};
|
|
Packit Service |
44c065 |
$localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0")
|
|
Packit Service |
44c065 |
if tied *STDIN && $] >= 5.008;
|
|
Packit Service |
44c065 |
$localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1")
|
|
Packit Service |
44c065 |
if $do_stdout && tied *STDOUT && $] >= 5.008;
|
|
Packit Service |
44c065 |
$localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2")
|
|
Packit Service |
44c065 |
if ($do_stderr || $do_merge) && tied *STDERR && $] >= 5.008;
|
|
Packit Service |
44c065 |
# _debug( "# localized $_\n" ) for keys %localize;
|
|
Packit Service |
44c065 |
# proxy any closed/localized handles so we don't use fds 0, 1 or 2
|
|
Packit Service |
44c065 |
my %proxy_std = _proxy_std();
|
|
Packit Service |
44c065 |
# _debug( "# proxy std: @{ [%proxy_std] }\n" );
|
|
Packit Service |
44c065 |
# update layers after any proxying
|
|
Packit Service |
44c065 |
$layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout};
|
|
Packit Service |
44c065 |
$layers{stderr} = [PerlIO::get_layers(\*STDERR, output => 1)] if $proxy_std{stderr};
|
|
Packit Service |
44c065 |
# _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
|
|
Packit Service |
44c065 |
# store old handles and setup handles for capture
|
|
Packit Service |
44c065 |
$stash->{old} = _copy_std();
|
|
Packit Service |
44c065 |
$stash->{new} = { %{$stash->{old}} }; # default to originals
|
|
Packit Service |
44c065 |
for ( keys %do ) {
|
|
Packit Service |
44c065 |
$stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new);
|
|
Packit Service |
44c065 |
seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n";
|
|
Packit Service |
44c065 |
$stash->{pos}{$_} = tell $stash->{capture}{$_};
|
|
Packit Service |
44c065 |
# _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" );
|
|
Packit Service |
44c065 |
_start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new}
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
_wait_for_tees( $stash ) if $do_tee;
|
|
Packit Service |
44c065 |
# finalize redirection
|
|
Packit Service |
44c065 |
$stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge;
|
|
Packit Service |
44c065 |
# _debug( "# redirecting in parent ...\n" );
|
|
Packit Service |
44c065 |
_open_std( $stash->{new} );
|
|
Packit Service |
44c065 |
# execute user provided code
|
|
Packit Service |
44c065 |
my ($exit_code, $inner_error, $outer_error, $orig_pid, @result);
|
|
Packit Service |
44c065 |
{
|
|
Packit Service |
44c065 |
$orig_pid = $$;
|
|
Packit Service |
44c065 |
local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN
|
|
Packit Service |
44c065 |
# _debug( "# finalizing layers ...\n" );
|
|
Packit Service |
44c065 |
_relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
|
|
Packit Service |
44c065 |
_relayer(\*STDERR, $layers{stderr}) if $do_stderr;
|
|
Packit Service |
44c065 |
# _debug( "# running code $code ...\n" );
|
|
Packit Service |
44c065 |
my $old_eval_err=$@;
|
|
Packit Service |
44c065 |
undef $@;
|
|
Packit Service |
44c065 |
eval { @result = $code->(); $inner_error = $@ };
|
|
Packit Service |
44c065 |
$exit_code = $?; # save this for later
|
|
Packit Service |
44c065 |
$outer_error = $@; # save this for later
|
|
Packit Service |
44c065 |
STDOUT->flush if $do_stdout;
|
|
Packit Service |
44c065 |
STDERR->flush if $do_stderr;
|
|
Packit Service |
44c065 |
$@ = $old_eval_err;
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
# restore prior filehandles and shut down tees
|
|
Packit Service |
44c065 |
# _debug( "# restoring filehandles ...\n" );
|
|
Packit Service |
44c065 |
_open_std( $stash->{old} );
|
|
Packit Service |
44c065 |
_close( $_ ) for values %{$stash->{old}}; # don't leak fds
|
|
Packit Service |
44c065 |
# shouldn't need relayering originals, but see rt.perl.org #114404
|
|
Packit Service |
44c065 |
_relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
|
|
Packit Service |
44c065 |
_relayer(\*STDERR, $layers{stderr}) if $do_stderr;
|
|
Packit Service |
44c065 |
_unproxy( %proxy_std );
|
|
Packit Service |
44c065 |
# _debug( "# killing tee subprocesses ...\n" ) if $do_tee;
|
|
Packit Service |
44c065 |
_kill_tees( $stash ) if $do_tee;
|
|
Packit Service |
44c065 |
# return captured output, but shortcut in void context
|
|
Packit Service |
44c065 |
# unless we have to echo output to tied/scalar handles;
|
|
Packit Service |
44c065 |
my %got;
|
|
Packit Service |
44c065 |
if ( $orig_pid == $$ and ( defined wantarray or ($do_tee && keys %localize) ) ) {
|
|
Packit Service |
44c065 |
for ( keys %do ) {
|
|
Packit Service |
44c065 |
_relayer($stash->{capture}{$_}, $layers{$_});
|
|
Packit Service |
44c065 |
$got{$_} = _slurp($_, $stash);
|
|
Packit Service |
44c065 |
# _debug("# slurped " . length($got{$_}) . " bytes from $_\n");
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
print CT_ORIG_STDOUT $got{stdout}
|
|
Packit Service |
44c065 |
if $do_stdout && $do_tee && $localize{stdout};
|
|
Packit Service |
44c065 |
print CT_ORIG_STDERR $got{stderr}
|
|
Packit Service |
44c065 |
if $do_stderr && $do_tee && $localize{stderr};
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
$? = $exit_code;
|
|
Packit Service |
44c065 |
$@ = $inner_error if $inner_error;
|
|
Packit Service |
44c065 |
die $outer_error if $outer_error;
|
|
Packit Service |
44c065 |
# _debug( "# ending _capture_tee with (@_)...\n" );
|
|
Packit Service |
44c065 |
return unless defined wantarray;
|
|
Packit Service |
44c065 |
my @return;
|
|
Packit Service |
44c065 |
push @return, $got{stdout} if $do_stdout;
|
|
Packit Service |
44c065 |
push @return, $got{stderr} if $do_stderr && ! $do_merge;
|
|
Packit Service |
44c065 |
push @return, @result;
|
|
Packit Service |
44c065 |
return wantarray ? @return : $return[0];
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
1;
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
__END__
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=pod
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=encoding UTF-8
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head1 NAME
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head1 VERSION
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
version 0.46
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head1 SYNOPSIS
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
use Capture::Tiny ':all';
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
# capture from external command
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
($stdout, $stderr, $exit) = capture {
|
|
Packit Service |
44c065 |
system( $cmd, @args );
|
|
Packit Service |
44c065 |
};
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
# capture from arbitrary code (Perl or external)
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
($stdout, $stderr, @result) = capture {
|
|
Packit Service |
44c065 |
# your code here
|
|
Packit Service |
44c065 |
};
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
# capture partial or merged output
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
$stdout = capture_stdout { ... };
|
|
Packit Service |
44c065 |
$stderr = capture_stderr { ... };
|
|
Packit Service |
44c065 |
$merged = capture_merged { ... };
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
# tee output
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
($stdout, $stderr) = tee {
|
|
Packit Service |
44c065 |
# your code here
|
|
Packit Service |
44c065 |
};
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
$stdout = tee_stdout { ... };
|
|
Packit Service |
44c065 |
$stderr = tee_stderr { ... };
|
|
Packit Service |
44c065 |
$merged = tee_merged { ... };
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head1 DESCRIPTION
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Capture::Tiny provides a simple, portable way to capture almost anything sent
|
|
Packit Service |
44c065 |
to STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or
|
|
Packit Service |
44c065 |
from an external program. Optionally, output can be teed so that it is
|
|
Packit Service |
44c065 |
captured while being passed through to the original filehandles. Yes, it even
|
|
Packit Service |
44c065 |
works on Windows (usually). Stop guessing which of a dozen capturing modules
|
|
Packit Service |
44c065 |
to use in any particular situation and just use this one.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head1 USAGE
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
The following functions are available. None are exported by default.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 capture
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
($stdout, $stderr, @result) = capture \&cod;;
|
|
Packit Service |
44c065 |
$stdout = capture \&cod;;
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
The C<capture> function takes a code reference and returns what is sent to
|
|
Packit Service |
44c065 |
STDOUT and STDERR as well as any return values from the code reference. In
|
|
Packit Service |
44c065 |
scalar context, it returns only STDOUT. If no output was received for a
|
|
Packit Service |
44c065 |
filehandle, it returns an empty string for that filehandle. Regardless of calling
|
|
Packit Service |
44c065 |
context, all output is captured -- nothing is passed to the existing filehandles.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
It is prototyped to take a subroutine reference as an argument. Thus, it
|
|
Packit Service |
44c065 |
can be called in block form:
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
($stdout, $stderr) = capture {
|
|
Packit Service |
44c065 |
# your code here ...
|
|
Packit Service |
44c065 |
};
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Note that the coderef is evaluated in list context. If you wish to force
|
|
Packit Service |
44c065 |
scalar context on the return value, you must use the C<scalar> keyword.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
($stdout, $stderr, $count) = capture {
|
|
Packit Service |
44c065 |
my @list = qw/one two three/;
|
|
Packit Service |
44c065 |
return scalar @list; # $count will be 3
|
|
Packit Service |
44c065 |
};
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Also note that within the coderef, the C<@_> variable will be empty. So don't
|
|
Packit Service |
44c065 |
use arguments from a surrounding subroutine without copying them to an array
|
|
Packit Service |
44c065 |
first:
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
sub wont_work {
|
|
Packit Service |
44c065 |
my ($stdout, $stderr) = capture { do_stuff( @_ ) }; # WRONG
|
|
Packit Service |
44c065 |
...
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
sub will_work {
|
|
Packit Service |
44c065 |
my @args = @_;
|
|
Packit Service |
44c065 |
my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT
|
|
Packit Service |
44c065 |
...
|
|
Packit Service |
44c065 |
}
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Captures are normally done to an anonymous temporary filehandle. To
|
|
Packit Service |
44c065 |
capture via a named file (e.g. to externally monitor a long-running capture),
|
|
Packit Service |
44c065 |
provide custom filehandles as a trailing list of option pairs:
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
my $out_fh = IO::File->new("out.txt", "w+");
|
|
Packit Service |
44c065 |
my $err_fh = IO::File->new("out.txt", "w+");
|
|
Packit Service |
44c065 |
capture { ... } stdout => $out_fh, stderr => $err_fh;
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
The filehandles must be read/write and seekable. Modifying the files or
|
|
Packit Service |
44c065 |
filehandles during a capture operation will give unpredictable results.
|
|
Packit Service |
44c065 |
Existing IO layers on them may be changed by the capture.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
When called in void context, C<capture> saves memory and time by
|
|
Packit Service |
44c065 |
not reading back from the capture handles.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 capture_stdout
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
($stdout, @result) = capture_stdout \&cod;;
|
|
Packit Service |
44c065 |
$stdout = capture_stdout \&cod;;
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
The C<capture_stdout> function works just like C<capture> except only
|
|
Packit Service |
44c065 |
STDOUT is captured. STDERR is not captured.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 capture_stderr
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
($stderr, @result) = capture_stderr \&cod;;
|
|
Packit Service |
44c065 |
$stderr = capture_stderr \&cod;;
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
The C<capture_stderr> function works just like C<capture> except only
|
|
Packit Service |
44c065 |
STDERR is captured. STDOUT is not captured.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 capture_merged
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
($merged, @result) = capture_merged \&cod;;
|
|
Packit Service |
44c065 |
$merged = capture_merged \&cod;;
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
The C<capture_merged> function works just like C<capture> except STDOUT and
|
|
Packit Service |
44c065 |
STDERR are merged. (Technically, STDERR is redirected to the same capturing
|
|
Packit Service |
44c065 |
handle as STDOUT before executing the function.)
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
|
|
Packit Service |
44c065 |
properly ordered due to buffering.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 tee
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
($stdout, $stderr, @result) = tee \&cod;;
|
|
Packit Service |
44c065 |
$stdout = tee \&cod;;
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
The C<tee> function works just like C<capture>, except that output is captured
|
|
Packit Service |
44c065 |
as well as passed on to the original STDOUT and STDERR.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
When called in void context, C<tee> saves memory and time by
|
|
Packit Service |
44c065 |
not reading back from the capture handles, except when the
|
|
Packit Service |
44c065 |
original STDOUT OR STDERR were tied or opened to a scalar
|
|
Packit Service |
44c065 |
handle.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 tee_stdout
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
($stdout, @result) = tee_stdout \&cod;;
|
|
Packit Service |
44c065 |
$stdout = tee_stdout \&cod;;
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
The C<tee_stdout> function works just like C<tee> except only
|
|
Packit Service |
44c065 |
STDOUT is teed. STDERR is not teed (output goes to STDERR as usual).
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 tee_stderr
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
($stderr, @result) = tee_stderr \&cod;;
|
|
Packit Service |
44c065 |
$stderr = tee_stderr \&cod;;
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
The C<tee_stderr> function works just like C<tee> except only
|
|
Packit Service |
44c065 |
STDERR is teed. STDOUT is not teed (output goes to STDOUT as usual).
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 tee_merged
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
($merged, @result) = tee_merged \&cod;;
|
|
Packit Service |
44c065 |
$merged = tee_merged \&cod;;
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
The C<tee_merged> function works just like C<capture_merged> except that output
|
|
Packit Service |
44c065 |
is captured as well as passed on to STDOUT.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
|
|
Packit Service |
44c065 |
properly ordered due to buffering.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head1 LIMITATIONS
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 Portability
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Portability is a goal, not a guarantee. C<tee> requires fork, except on
|
|
Packit Service |
44c065 |
Windows where C<system(1, @cmd)> is used instead. Not tested on any
|
|
Packit Service |
44c065 |
particularly esoteric platforms yet. See the
|
|
Packit Service |
44c065 |
L<CPAN Testers Matrix|http://matrix.cpantesters.org/?dist=Capture-Tiny>
|
|
Packit Service |
44c065 |
for test result by platform.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 PerlIO layers
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Capture::Tiny does its best to preserve PerlIO layers such as ':utf8' or
|
|
Packit Service |
44c065 |
':crlf' when capturing (only for Perl 5.8.1+) . Layers should be applied to
|
|
Packit Service |
44c065 |
STDOUT or STDERR I<before> the call to C<capture> or C<tee>. This may not work
|
|
Packit Service |
44c065 |
for tied filehandles (see below).
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 Modifying filehandles before capturing
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Generally speaking, you should do little or no manipulation of the standard IO
|
|
Packit Service |
44c065 |
filehandles prior to using Capture::Tiny. In particular, closing, reopening,
|
|
Packit Service |
44c065 |
localizing or tying standard filehandles prior to capture may cause a variety of
|
|
Packit Service |
44c065 |
unexpected, undesirable and/or unreliable behaviors, as described below.
|
|
Packit Service |
44c065 |
Capture::Tiny does its best to compensate for these situations, but the
|
|
Packit Service |
44c065 |
results may not be what you desire.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head3 Closed filehandles
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously
|
|
Packit Service |
44c065 |
closed. However, since they will be reopened to capture or tee output, any
|
|
Packit Service |
44c065 |
code within the captured block that depends on finding them closed will, of
|
|
Packit Service |
44c065 |
course, not find them to be closed. If they started closed, Capture::Tiny will
|
|
Packit Service |
44c065 |
close them again when the capture block finishes.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Note that this reopening will happen even for STDIN or a filehandle not being
|
|
Packit Service |
44c065 |
captured to ensure that the filehandle used for capture is not opened to file
|
|
Packit Service |
44c065 |
descriptor 0, as this causes problems on various platforms.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles
|
|
Packit Service |
44c065 |
and also breaks tee() for undiagnosed reasons. So don't do that.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head3 Localized filehandles
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
If code localizes any of Perl's standard filehandles before capturing, the capture
|
|
Packit Service |
44c065 |
will affect the localized filehandles and not the original ones. External system
|
|
Packit Service |
44c065 |
calls are not affected by localizing a filehandle in Perl and will continue
|
|
Packit Service |
44c065 |
to send output to the original filehandles (which will thus not be captured).
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head3 Scalar filehandles
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
If STDOUT or STDERR are reopened to scalar filehandles prior to the call to
|
|
Packit Service |
44c065 |
C<capture> or C<tee>, then Capture::Tiny will override the output filehandle for
|
|
Packit Service |
44c065 |
the duration of the C<capture> or C<tee> call and then, for C<tee>, send captured
|
|
Packit Service |
44c065 |
output to the output filehandle after the capture is complete. (Requires Perl
|
|
Packit Service |
44c065 |
5.8)
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar
|
|
Packit Service |
44c065 |
reference, but note that external processes will not be able to read from such
|
|
Packit Service |
44c065 |
a handle. Capture::Tiny tries to ensure that external processes will read from
|
|
Packit Service |
44c065 |
the null device instead, but this is not guaranteed.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head3 Tied output filehandles
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
If STDOUT or STDERR are tied prior to the call to C<capture> or C<tee>, then
|
|
Packit Service |
44c065 |
Capture::Tiny will attempt to override the tie for the duration of the
|
|
Packit Service |
44c065 |
C<capture> or C<tee> call and then send captured output to the tied filehandle after
|
|
Packit Service |
44c065 |
the capture is complete. (Requires Perl 5.8)
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Capture::Tiny may not succeed resending UTF-8 encoded data to a tied
|
|
Packit Service |
44c065 |
STDOUT or STDERR filehandle. Characters may appear as bytes. If the tied filehandle
|
|
Packit Service |
44c065 |
is based on L<Tie::StdHandle>, then Capture::Tiny will attempt to determine
|
|
Packit Service |
44c065 |
appropriate layers like C<:utf8> from the underlying filehandle and do the right
|
|
Packit Service |
44c065 |
thing.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head3 Tied input filehandle
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Capture::Tiny attempts to preserve the semantics of tied STDIN, but this
|
|
Packit Service |
44c065 |
requires Perl 5.8 and is not entirely predictable. External processes
|
|
Packit Service |
44c065 |
will not be able to read from such a handle.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Unless having STDIN tied is crucial, it may be safest to localize STDIN when
|
|
Packit Service |
44c065 |
capturing:
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
my ($out, $err) = do { local *STDIN; capture { ... } };
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 Modifying filehandles during a capture
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Attempting to modify STDIN, STDOUT or STDERR I<during> C<capture> or C<tee> is
|
|
Packit Service |
44c065 |
almost certainly going to cause problems. Don't do that.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head3 Forking inside a capture
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Forks aren't portable. The behavior of filehandles during a fork is even
|
|
Packit Service |
44c065 |
less so. If Capture::Tiny detects that a fork has occurred within a
|
|
Packit Service |
44c065 |
capture, it will shortcut in the child process and return empty strings for
|
|
Packit Service |
44c065 |
captures. Other problems may occur in the child or parent, as well.
|
|
Packit Service |
44c065 |
Forking in a capture block is not recommended.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head3 Using threads
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Filehandles are global. Mixing up I/O and captures in different threads
|
|
Packit Service |
44c065 |
without coordination is going to cause problems. Besides, threads are
|
|
Packit Service |
44c065 |
officially discouraged.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head3 Dropping privileges during a capture
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
If you drop privileges during a capture, temporary files created to
|
|
Packit Service |
44c065 |
facilitate the capture may not be cleaned up afterwards.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 No support for Perl 5.8.0
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
It's just too buggy when it comes to layers and UTF-8. Perl 5.8.1 or later
|
|
Packit Service |
44c065 |
is recommended.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 Limited support for Perl 5.6
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Perl 5.6 predates PerlIO. UTF-8 data may not be captured correctly.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head1 ENVIRONMENT
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 PERL_CAPTURE_TINY_TIMEOUT
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Capture::Tiny uses subprocesses internally for C<tee>. By default,
|
|
Packit Service |
44c065 |
Capture::Tiny will timeout with an error if such subprocesses are not ready to
|
|
Packit Service |
44c065 |
receive data within 30 seconds (or whatever is the value of
|
|
Packit Service |
44c065 |
C<$Capture::Tiny::TIMEOUT>). An alternate timeout may be specified by setting
|
|
Packit Service |
44c065 |
the C<PERL_CAPTURE_TINY_TIMEOUT> environment variable. Setting it to zero will
|
|
Packit Service |
44c065 |
disable timeouts. B<NOTE>, this does not timeout the code reference being
|
|
Packit Service |
44c065 |
captured -- this only prevents Capture::Tiny itself from hanging your process
|
|
Packit Service |
44c065 |
waiting for its child processes to be ready to proceed.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head1 SEE ALSO
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
This module was inspired by L<IO::CaptureOutput>, which provides
|
|
Packit Service |
44c065 |
similar functionality without the ability to tee output and with more
|
|
Packit Service |
44c065 |
complicated code and API. L<IO::CaptureOutput> does not handle layers
|
|
Packit Service |
44c065 |
or most of the unusual cases described in the L</Limitations> section and
|
|
Packit Service |
44c065 |
I no longer recommend it.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
There are many other CPAN modules that provide some sort of output capture,
|
|
Packit Service |
44c065 |
albeit with various limitations that make them appropriate only in particular
|
|
Packit Service |
44c065 |
circumstances. I'm probably missing some. The long list is provided to show
|
|
Packit Service |
44c065 |
why I felt Capture::Tiny was necessary.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=over 4
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<IO::Capture>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<IO::Capture::Extended>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<IO::CaptureOutput>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<IPC::Capture>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<IPC::Cmd>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<IPC::Open2>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<IPC::Open3>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<IPC::Open3::Simple>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<IPC::Open3::Utils>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<IPC::Run>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<IPC::Run::SafeHandles>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<IPC::Run::Simple>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<IPC::Run3>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<IPC::System::Simple>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<Tee>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<IO::Tee>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<File::Tee>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<Filter::Handle>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<Tie::STDERR>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<Tie::STDOUT>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<Test::Output>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=back
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head1 SUPPORT
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 Bugs / Feature Requests
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Please report any bugs or feature requests through the issue tracker
|
|
Packit Service |
44c065 |
at L<https://github.com/dagolden/Capture-Tiny/issues>.
|
|
Packit Service |
44c065 |
You will be notified automatically of any progress on your issue.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head2 Source Code
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
This is open source software. The code repository is available for
|
|
Packit Service |
44c065 |
public review and contribution under the terms of the license.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
L<https://github.com/dagolden/Capture-Tiny>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
git clone https://github.com/dagolden/Capture-Tiny.git
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head1 AUTHOR
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
David Golden <dagolden@cpan.org>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head1 CONTRIBUTORS
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=for stopwords Dagfinn Ilmari Mannsåker David E. Wheeler fecundf Graham Knop Peter Rabbitson
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=over 4
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
David E. Wheeler <david@justatheory.com>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
fecundf <not.com+github@gmail.com>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Graham Knop <haarg@haarg.org>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=item *
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
Peter Rabbitson <ribasushi@cpan.org>
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=back
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=head1 COPYRIGHT AND LICENSE
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
This software is Copyright (c) 2009 by David Golden.
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
This is free software, licensed under:
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
The Apache License, Version 2.0, January 2004
|
|
Packit Service |
44c065 |
|
|
Packit Service |
44c065 |
=cut
|