File Coverage

File:/usr/local/share/perl/5.38.2/Capture/Tiny.pm
Coverage:49.6%

linestmtbrancondsubtimecode
1
4
4
4
115383
4
use 5.006;
2
4
4
4
4
5
2
31
use strict;
3
4
4
4
4
9
1
128
use warnings;
4package Capture::Tiny;
5# ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs
6our $VERSION = '0.50';
7
4
4
4
4
5
6
25
use Carp ();
8
4
4
4
4
5
1
17
use Exporter ();
9
4
4
4
4
161
2573
24
use IO::Handle ();
10
4
4
4
4
5
3
32
use File::Spec ();
11
4
4
4
4
347
5711
87
use File::Temp qw/tempfile tmpnam/;
12
4
4
4
4
12
2
139
use Scalar::Util qw/reftype blessed/;
13# Get PerlIO or fake it
14BEGIN {
15
4
4
3
  local $@;
16
4
4
514
583
  eval { require PerlIO; PerlIO->can('get_layers') }
17
4
0
50
3
0
    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
25my %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
36for my $sub ( keys %api ) {
37  my $args = join q{, }, @{$api{$sub}};
38
26
26
0
0
0
0
0
0
0
0
0
0
0
0
0
0
26
0
0
0
0
0
0
0
25307
67
0
0
0
0
0
0
0
0
0
0
0
0
0
0
  eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic
39}
40
41our @ISA = qw/Exporter/;
42our @EXPORT_OK = keys %api;
43our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
44
45#--------------------------------------------------------------------------#
46# constants and fixtures
47#--------------------------------------------------------------------------#
48
49my $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
58our $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#--------------------------------------------------------------------------#
66my @cmd = ($^X, '-C0', '-e', <<'HERE');
67use Fcntl;
68$SIG{HUP}=sub{exit};
69if ( my $fn=shift ) {
70    sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!;
71    print {$fh} $$;
72    close $fh;
73}
74my $buf; while (sysread(STDIN, $buf, 2048)) {
75    syswrite(STDOUT, $buf); syswrite(STDERR, $buf);
76}
77HERE
78
79#--------------------------------------------------------------------------#
80# filehandle manipulation
81#--------------------------------------------------------------------------#
82
83sub _relayer {
84
156
156
102
  my ($fh, $apply_layers) = @_;
85  # _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n");
86
87  # eliminate pseudo-layers
88
156
158
  binmode( $fh, ":raw" );
89  # strip off real layers until only :unix is left
90
156
285
  while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
91
156
255
      binmode( $fh, ":pop" );
92  }
93  # apply other layers
94
156
143
  my @to_apply = @$apply_layers;
95
156
82
  shift @to_apply; # eliminate initial :unix
96  # _debug("# applying layers  (unix @to_apply) to @{[fileno $fh]}\n");
97
156
360
  binmode($fh, ":" . join(":",@to_apply));
98}
99
100sub _name {
101
0
0
0
  my $glob = shift;
102
4
4
4
4
6
1
4550
  no strict 'refs'; ## no critic
103
0
0
0
0
  return *{$glob}{NAME};
104}
105
106sub _open {
107
156
50
156
1443
  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
111sub _close {
112  # _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' )  . " on " . fileno( $_[0] ) . "\n" );
113
52
50
52
93
  close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!";
114}
115
116my %dup; # cache this so STDIN stays fd0
117my %proxy_count;
118sub _proxy_std {
119
26
26
10
  my %proxies;
120
26
50
29
  if ( ! defined fileno STDIN ) {
121
0
0
    $proxy_count{stdin}++;
122
0
0
0
    if (defined $dup{stdin}) {
123
0
0
      _open \*STDIN, "<&=" . fileno($dup{stdin});
124      # _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
125    }
126    else {
127
0
0
      _open \*STDIN, "<" . File::Spec->devnull;
128      # _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
129
0
0
      _open $dup{stdin} = IO::Handle->new, "<&=STDIN";
130    }
131
0
0
    $proxies{stdin} = \*STDIN;
132
0
0
0
    binmode(STDIN, ':utf8') if $] >= 5.008; ## no critic
133  }
134
26
50
29
  if ( ! defined fileno STDOUT ) {
135
0
0
    $proxy_count{stdout}++;
136
0
0
0
    if (defined $dup{stdout}) {
137
0
0
      _open \*STDOUT, ">&=" . fileno($dup{stdout});
138      # _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
139    }
140    else {
141
0
0
      _open \*STDOUT, ">" . File::Spec->devnull;
142       # _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
143
0
0
      _open $dup{stdout} = IO::Handle->new, ">&=STDOUT";
144    }
145
0
0
    $proxies{stdout} = \*STDOUT;
146
0
0
0
    binmode(STDOUT, ':utf8') if $] >= 5.008; ## no critic
147  }
148
26
50
24
  if ( ! defined fileno STDERR ) {
149
0
0
    $proxy_count{stderr}++;
150
0
0
0
    if (defined $dup{stderr}) {
151
0
0
      _open \*STDERR, ">&=" . fileno($dup{stderr});
152       # _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
153    }
154    else {
155
0
0
      _open \*STDERR, ">" . File::Spec->devnull;
156       # _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
157
0
0
      _open $dup{stderr} = IO::Handle->new, ">&=STDERR";
158    }
159
0
0
    $proxies{stderr} = \*STDERR;
160
0
0
0
    binmode(STDERR, ':utf8') if $] >= 5.008; ## no critic
161  }
162
26
33
  return %proxies;
163}
164
165sub _unproxy {
166
26
26
20
  my (%proxies) = @_;
167  # _debug( "# unproxying: " . join(" ", keys %proxies) . "\n" );
168
26
37
  for my $p ( keys %proxies ) {
169
0
0
    $proxy_count{$p}--;
170    # _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" );
171
0
0
0
    if ( ! $proxy_count{$p} ) {
172
0
0
      _close $proxies{$p};
173
0
0
0
      _close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup
174
0
0
      delete $dup{$p};
175    }
176  }
177}
178
179sub _copy_std {
180
26
26
12
  my %handles;
181
26
29
  for my $h ( qw/stdout stderr stdin/ ) {
182
78
100
67
101
    next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied
183
52
50
40
    my $redir = $h eq 'stdin' ? "<&" : ">&";
184
52
104
    _open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN"
185  }
186
26
32
  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)
191sub _open_std {
192
52
52
38
  my ($handles) = @_;
193
52
50
46
  _open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin};
194
52
50
115
  _open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout};
195
52
50
98
  _open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr};
196}
197
198#--------------------------------------------------------------------------#
199# private subs
200#--------------------------------------------------------------------------#
201
202sub _start_tee {
203
0
0
0
  my ($which, $stash) = @_; # $which is "stdout" or "stderr"
204  # setup pipes
205
0
0
  $stash->{$_}{$which} = IO::Handle->new for qw/tee reader/;
206
0
0
  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
0
0
  select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush
209  # setup desired redirection for parent and child
210
0
0
  $stash->{new}{$which} = $stash->{tee}{$which};
211  $stash->{child}{$which} = {
212    stdin   => $stash->{reader}{$which},
213    stdout  => $stash->{old}{$which},
214
0
0
    stderr  => $stash->{capture}{$which},
215  };
216  # flag file is used to signal the child is ready
217
0
0
  $stash->{flag_files}{$which} = scalar( tmpnam() ) . $$;
218  # execute @cmd as a separate process
219
0
0
0
  if ( $IS_WIN32 ) {
220
0
0
    my $old_eval_err=$@;
221
0
0
    undef $@;
222
223
0
0
    eval "use Win32API::File qw/GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ ";
224    # _debug( "# Win32API::File loaded\n") unless $@;
225
0
0
    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
0
0
    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
0
0
    _open_std( $stash->{child}{$which} );
230
0
0
    $stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which});
231    # not restoring std here as it all gets redirected again shortly anyway
232
0
0
    $@=$old_eval_err;
233  }
234  else { # use fork
235
0
0
    _fork_exec( $which, $stash );
236  }
237}
238
239sub _fork_exec {
240
0
0
0
  my ($which, $stash) = @_; # $which is "stdout" or "stderr"
241
0
0
  my $pid = fork;
242
0
0
0
0
  if ( not defined $pid ) {
243
0
0
    Carp::confess "Couldn't fork(): $!";
244  }
245  elsif ($pid == 0) { # child
246    # _debug( "# in child process ...\n" );
247
0
0
0
0
0
0
    untie *STDIN; untie *STDOUT; untie *STDERR;
248
0
0
    _close $stash->{tee}{$which};
249    # _debug( "# redirecting handles in child ...\n" );
250
0
0
    _open_std( $stash->{child}{$which} );
251    # _debug( "# calling exec on command ...\n" );
252
0
0
    exec @cmd, $stash->{flag_files}{$which};
253  }
254
0
0
  $stash->{pid}{$which} = $pid
255}
256
257
4
4
4
4
454
1001
11
my $have_usleep = eval "use Time::HiRes 'usleep'; 1";
258sub _files_exist {
259
0
0
0
0
0
0
  return 1 if @_ == grep { -f } @_;
260
0
0
0
  Time::HiRes::usleep(1000) if $have_usleep;
261
0
0
  return 0;
262}
263
264sub _wait_for_tees {
265
0
0
0
  my ($stash) = @_;
266
0
0
  my $start = time;
267
0
0
0
0
  my @files = values %{$stash->{flag_files}};
268  my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT}
269
0
0
0
              ? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT;
270
0
0
0
  1 until _files_exist(@files) || ($timeout && (time - $start > $timeout));
271
0
0
0
  Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files);
272
0
0
  unlink $_ for @files;
273}
274
275sub _kill_tees {
276
0
0
0
  my ($stash) = @_;
277
0
0
0
  if ( $IS_WIN32 ) {
278    # _debug( "# closing handles\n");
279
0
0
0
0
    close($_) for values %{ $stash->{tee} };
280    # _debug( "# waiting for subprocesses to finish\n");
281
0
0
    my $start = time;
282
0
0
0
    1 until wait == -1 || (time - $start > 30);
283  }
284  else {
285
0
0
0
0
    _close $_ for values %{ $stash->{tee} };
286
0
0
0
0
    waitpid $_, 0 for values %{ $stash->{pid} };
287  }
288}
289
290sub _slurp {
291
52
52
34
  my ($name, $stash) = @_;
292
52
104
34
110
  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
52
50
97
  seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n";
295
52
52
52
25
52
377
  my $text = do { local $/; scalar readline $fh };
296
52
50
130
  return defined($text) ? $text : "";
297}
298
299#--------------------------------------------------------------------------#
300# _capture_tee() -- generic main sub for capturing or teeing
301#--------------------------------------------------------------------------#
302
303sub _capture_tee {
304  # _debug( "# starting _capture_tee with (@_)...\n" );
305
26
26
38
  my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_;
306
26
50
50
69
  my %do = ($do_stdout ? (stdout => 1) : (),  $do_stderr ? (stderr => 1) : ());
307
26
50
42
  Carp::confess("Custom capture options must be given as key/value pairs\n")
308    unless @opts % 2 == 0;
309
26
39
  my $stash = { capture => { @opts } };
310
26
26
19
44
  for ( keys %{$stash->{capture}} ) {
311
0
0
    my $fh = $stash->{capture}{$_};
312
0
0
0
0
    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
26
43
  local *CT_ORIG_STDIN  = *STDIN ;
317
26
24
  local *CT_ORIG_STDOUT = *STDOUT;
318
26
23
  local *CT_ORIG_STDERR = *STDERR;
319  # find initial layers
320
26
159
  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
26
50
33
41
  $layers{stdout} = [PerlIO::get_layers(tied *STDOUT)]
329    if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB');
330
26
50
33
32
  $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
26
21
  my %localize;
336  $localize{stdin}++,  local(*STDIN)
337
26
52
26
50
14
60
24
    if grep { $_ eq 'scalar' } @{$layers{stdin}};
338  $localize{stdout}++, local(*STDOUT)
339
26
52
26
50
33
51
84
17
    if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}};
340  $localize{stderr}++, local(*STDERR)
341
26
52
26
50
20
50
48
16
    if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}};
342
26
50
33
29
  $localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0")
343    if tied *STDIN && $] >= 5.008;
344
26
50
25
57
  $localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1")
345    if $do_stdout && tied *STDOUT && $] >= 5.008;
346
26
50
14
60
  $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
26
39
  my %proxy_std = _proxy_std();
351  # _debug( "# proxy std: @{ [%proxy_std] }\n" );
352  # update layers after any proxying
353
26
50
28
  $layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout};
354
26
50
26
  $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
26
28
  $stash->{old} = _copy_std();
358
26
26
14
52
  $stash->{new} = { %{$stash->{old}} }; # default to originals
359
26
34
  for ( keys %do ) {
360
52
33
118
    $stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new);
361
52
50
7431
    seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n";
362
52
62
    $stash->{pos}{$_} = tell $stash->{capture}{$_};
363    # _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" );
364
52
50
59
    _start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new}
365  }
366
26
50
24
  _wait_for_tees( $stash ) if $do_tee;
367  # finalize redirection
368
26
50
23
  $stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge;
369  # _debug( "# redirecting in parent ...\n" );
370
26
34
  _open_std( $stash->{new} );
371  # execute user provided code
372
26
21
  my ($exit_code, $inner_error, $outer_error, $orig_pid, @result);
373  {
374
26
26
30
34
    $orig_pid = $$;
375
26
50
32
    local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN
376    # _debug( "# finalizing layers ...\n" );
377
26
50
38
    _relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
378
26
50
32
    _relayer(\*STDERR, $layers{stderr}) if $do_stderr;
379    # _debug( "# running code $code ...\n" );
380
26
17
    my $old_eval_err=$@;
381
26
20
    undef $@;
382
26
26
26
12
40
325
    eval { @result = $code->(); $inner_error = $@ };
383
26
40
    $exit_code = $?; # save this for later
384
26
16
    $outer_error = $@; # save this for later
385
26
50
98
    STDOUT->flush if $do_stdout;
386
26
50
42
    STDERR->flush if $do_stderr;
387
26
22
    $@ = $old_eval_err;
388  }
389  # restore prior filehandles and shut down tees
390  # _debug( "# restoring filehandles ...\n" );
391
26
47
  _open_std( $stash->{old} );
392
26
26
24
48
  _close( $_ ) for values %{$stash->{old}}; # don't leak fds
393  # shouldn't need relayering originals, but see rt.perl.org #114404
394
26
50
41
  _relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
395
26
50
45
  _relayer(\*STDERR, $layers{stderr}) if $do_stderr;
396
26
53
  _unproxy( %proxy_std );
397  # _debug( "# killing tee subprocesses ...\n" ) if $do_tee;
398
26
50
20
  _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
26
14
  my %got;
402
26
50
0
77
  if ( $orig_pid == $$ and ( defined wantarray or ($do_tee && keys %localize) ) ) {
403
26
29
    for ( keys %do ) {
404
52
50
      _relayer($stash->{capture}{$_}, $layers{$_});
405
52
61
      $got{$_} = _slurp($_, $stash);
406      # _debug("# slurped " . length($got{$_}) . " bytes from $_\n");
407    }
408    print CT_ORIG_STDOUT $got{stdout}
409
26
0
25
85
      if $do_stdout && $do_tee && $localize{stdout};
410    print CT_ORIG_STDERR $got{stderr}
411
26
0
25
57
      if $do_stderr && $do_tee && $localize{stderr};
412  }
413
26
17
  $? = $exit_code;
414
26
100
19
  $@ = $inner_error if $inner_error;
415
26
50
27
  die $outer_error if $outer_error;
416  # _debug( "# ending _capture_tee with (@_)...\n" );
417
26
50
18
  return unless defined wantarray;
418
26
13
  my @return;
419
26
50
41
  push @return, $got{stdout} if $do_stdout;
420
26
50
33
60
  push @return, $got{stderr} if $do_stderr && ! $do_merge;
421
26
29
  push @return, @result;
422
26
50
144
  return wantarray ? @return : $return[0];
423}
424
4251;
426