This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
c0e25a22fb367b265ea932a1a5033c835259a252
[perl5.git] / cpan / IPC-Cmd / lib / IPC / Cmd.pm
1 package IPC::Cmd;
2
3 use strict;
4
5 BEGIN {
6
7     use constant IS_VMS         => $^O eq 'VMS'                       ? 1 : 0;
8     use constant IS_WIN32       => $^O eq 'MSWin32'                   ? 1 : 0;
9     use constant IS_WIN98       => (IS_WIN32 and !Win32::IsWinNT())   ? 1 : 0;
10     use constant ALARM_CLASS    => __PACKAGE__ . '::TimeOut';
11     use constant SPECIAL_CHARS  => qw[< > | &];
12     use constant QUOTE          => do { IS_WIN32 ? q["] : q['] };
13
14     use Exporter    ();
15     use vars        qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG
16                         $USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN
17                         $INSTANCES $ALLOW_NULL_ARGS
18                         $HAVE_MONOTONIC
19                     ];
20
21     $VERSION        = '0.96';
22     $VERBOSE        = 0;
23     $DEBUG          = 0;
24     $WARN           = 1;
25     $USE_IPC_RUN    = IS_WIN32 && !IS_WIN98;
26     $USE_IPC_OPEN3  = not IS_VMS;
27     $ALLOW_NULL_ARGS = 0;
28
29     $CAN_USE_RUN_FORKED = 0;
30     eval {
31         require POSIX; POSIX->import();
32         require IPC::Open3; IPC::Open3->import();
33         require IO::Select; IO::Select->import();
34         require IO::Handle; IO::Handle->import();
35         require FileHandle; FileHandle->import();
36         require Socket;
37         require Time::HiRes; Time::HiRes->import();
38         require Win32 if IS_WIN32;
39     };
40     $CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32;
41
42     eval {
43         my $wait_start_time = Time::HiRes::clock_gettime(&Time::HiRes::CLOCK_MONOTONIC);
44     };
45     if ($@) {
46         $HAVE_MONOTONIC = 0;
47     }
48     else {
49         $HAVE_MONOTONIC = 1;
50     }
51
52     @ISA            = qw[Exporter];
53     @EXPORT_OK      = qw[can_run run run_forked QUOTE];
54 }
55
56 require Carp;
57 use File::Spec;
58 use Params::Check               qw[check];
59 use Text::ParseWords            ();             # import ONLY if needed!
60 use Module::Load::Conditional   qw[can_load];
61 use Locale::Maketext::Simple    Style => 'gettext';
62
63 local $Module::Load::Conditional::FORCE_SAFE_INC = 1;
64
65 =pod
66
67 =head1 NAME
68
69 IPC::Cmd - finding and running system commands made easy
70
71 =head1 SYNOPSIS
72
73     use IPC::Cmd qw[can_run run run_forked];
74
75     my $full_path = can_run('wget') or warn 'wget is not installed!';
76
77     ### commands can be arrayrefs or strings ###
78     my $cmd = "$full_path -b theregister.co.uk";
79     my $cmd = [$full_path, '-b', 'theregister.co.uk'];
80
81     ### in scalar context ###
82     my $buffer;
83     if( scalar run( command => $cmd,
84                     verbose => 0,
85                     buffer  => \$buffer,
86                     timeout => 20 )
87     ) {
88         print "fetched webpage successfully: $buffer\n";
89     }
90
91
92     ### in list context ###
93     my( $success, $error_message, $full_buf, $stdout_buf, $stderr_buf ) =
94             run( command => $cmd, verbose => 0 );
95
96     if( $success ) {
97         print "this is what the command printed:\n";
98         print join "", @$full_buf;
99     }
100
101     ### run_forked example ###
102     my $result = run_forked("$full_path -q -O - theregister.co.uk", {'timeout' => 20});
103     if ($result->{'exit_code'} eq 0 && !$result->{'timeout'}) {
104         print "this is what wget returned:\n";
105         print $result->{'stdout'};
106     }
107
108     ### check for features
109     print "IPC::Open3 available: "  . IPC::Cmd->can_use_ipc_open3;
110     print "IPC::Run available: "    . IPC::Cmd->can_use_ipc_run;
111     print "Can capture buffer: "    . IPC::Cmd->can_capture_buffer;
112
113     ### don't have IPC::Cmd be verbose, ie don't print to stdout or
114     ### stderr when running commands -- default is '0'
115     $IPC::Cmd::VERBOSE = 0;
116
117
118 =head1 DESCRIPTION
119
120 IPC::Cmd allows you to run commands platform independently,
121 interactively if desired, but have them still work.
122
123 The C<can_run> function can tell you if a certain binary is installed
124 and if so where, whereas the C<run> function can actually execute any
125 of the commands you give it and give you a clear return value, as well
126 as adhere to your verbosity settings.
127
128 =head1 CLASS METHODS
129
130 =head2 $ipc_run_version = IPC::Cmd->can_use_ipc_run( [VERBOSE] )
131
132 Utility function that tells you if C<IPC::Run> is available.
133 If the C<verbose> flag is passed, it will print diagnostic messages
134 if L<IPC::Run> can not be found or loaded.
135
136 =cut
137
138
139 sub can_use_ipc_run     {
140     my $self    = shift;
141     my $verbose = shift || 0;
142
143     ### IPC::Run doesn't run on win98
144     return if IS_WIN98;
145
146     ### if we don't have ipc::run, we obviously can't use it.
147     return unless can_load(
148                         modules => { 'IPC::Run' => '0.55' },
149                         verbose => ($WARN && $verbose),
150                     );
151
152     ### otherwise, we're good to go
153     return $IPC::Run::VERSION;
154 }
155
156 =head2 $ipc_open3_version = IPC::Cmd->can_use_ipc_open3( [VERBOSE] )
157
158 Utility function that tells you if C<IPC::Open3> is available.
159 If the verbose flag is passed, it will print diagnostic messages
160 if C<IPC::Open3> can not be found or loaded.
161
162 =cut
163
164
165 sub can_use_ipc_open3   {
166     my $self    = shift;
167     my $verbose = shift || 0;
168
169     ### IPC::Open3 is not working on VMS because of a lack of fork.
170     return if IS_VMS;
171
172     ### IPC::Open3 works on every non-VMS platform, but it can't
173     ### capture buffers on win32 :(
174     return unless can_load(
175         modules => { map {$_ => '0.0'} qw|IPC::Open3 IO::Select Symbol| },
176         verbose => ($WARN && $verbose),
177     );
178
179     return $IPC::Open3::VERSION;
180 }
181
182 =head2 $bool = IPC::Cmd->can_capture_buffer
183
184 Utility function that tells you if C<IPC::Cmd> is capable of
185 capturing buffers in it's current configuration.
186
187 =cut
188
189 sub can_capture_buffer {
190     my $self    = shift;
191
192     return 1 if $USE_IPC_RUN    && $self->can_use_ipc_run;
193     return 1 if $USE_IPC_OPEN3  && $self->can_use_ipc_open3;
194     return;
195 }
196
197 =head2 $bool = IPC::Cmd->can_use_run_forked
198
199 Utility function that tells you if C<IPC::Cmd> is capable of
200 providing C<run_forked> on the current platform.
201
202 =head1 FUNCTIONS
203
204 =head2 $path = can_run( PROGRAM );
205
206 C<can_run> takes only one argument: the name of a binary you wish
207 to locate. C<can_run> works much like the unix binary C<which> or the bash
208 command C<type>, which scans through your path, looking for the requested
209 binary.
210
211 Unlike C<which> and C<type>, this function is platform independent and
212 will also work on, for example, Win32.
213
214 If called in a scalar context it will return the full path to the binary
215 you asked for if it was found, or C<undef> if it was not.
216
217 If called in a list context and the global variable C<$INSTANCES> is a true
218 value, it will return a list of the full paths to instances
219 of the binary where found in C<PATH>, or an empty list if it was not found.
220
221 =cut
222
223 sub can_run {
224     my $command = shift;
225
226     # a lot of VMS executables have a symbol defined
227     # check those first
228     if ( $^O eq 'VMS' ) {
229         require VMS::DCLsym;
230         my $syms = VMS::DCLsym->new;
231         return $command if scalar $syms->getsym( uc $command );
232     }
233
234     require File::Spec;
235     require ExtUtils::MakeMaker;
236
237     my @possibles;
238
239     if( File::Spec->file_name_is_absolute($command) ) {
240         return MM->maybe_command($command);
241
242     } else {
243         for my $dir (
244             File::Spec->path,
245             File::Spec->curdir
246         ) {
247             next if ! $dir || ! -d $dir;
248             my $abs = File::Spec->catfile( IS_WIN32 ? Win32::GetShortPathName( $dir ) : $dir, $command);
249             push @possibles, $abs if $abs = MM->maybe_command($abs);
250         }
251     }
252     return @possibles if wantarray and $INSTANCES;
253     return shift @possibles;
254 }
255
256 =head2 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR, timeout => DIGIT] );
257
258 C<run> takes 4 arguments:
259
260 =over 4
261
262 =item command
263
264 This is the command to execute. It may be either a string or an array
265 reference.
266 This is a required argument.
267
268 See L<"Caveats"> for remarks on how commands are parsed and their
269 limitations.
270
271 =item verbose
272
273 This controls whether all output of a command should also be printed
274 to STDOUT/STDERR or should only be trapped in buffers (NOTE: buffers
275 require L<IPC::Run> to be installed, or your system able to work with
276 L<IPC::Open3>).
277
278 It will default to the global setting of C<$IPC::Cmd::VERBOSE>,
279 which by default is 0.
280
281 =item buffer
282
283 This will hold all the output of a command. It needs to be a reference
284 to a scalar.
285 Note that this will hold both the STDOUT and STDERR messages, and you
286 have no way of telling which is which.
287 If you require this distinction, run the C<run> command in list context
288 and inspect the individual buffers.
289
290 Of course, this requires that the underlying call supports buffers. See
291 the note on buffers above.
292
293 =item timeout
294
295 Sets the maximum time the command is allowed to run before aborting,
296 using the built-in C<alarm()> call. If the timeout is triggered, the
297 C<errorcode> in the return value will be set to an object of the
298 C<IPC::Cmd::TimeOut> class. See the L<"error message"> section below for
299 details.
300
301 Defaults to C<0>, meaning no timeout is set.
302
303 =back
304
305 C<run> will return a simple C<true> or C<false> when called in scalar
306 context.
307 In list context, you will be returned a list of the following items:
308
309 =over 4
310
311 =item success
312
313 A simple boolean indicating if the command executed without errors or
314 not.
315
316 =item error message
317
318 If the first element of the return value (C<success>) was 0, then some
319 error occurred. This second element is the error message the command
320 you requested exited with, if available. This is generally a pretty
321 printed value of C<$?> or C<$@>. See C<perldoc perlvar> for details on
322 what they can contain.
323 If the error was a timeout, the C<error message> will be prefixed with
324 the string C<IPC::Cmd::TimeOut>, the timeout class.
325
326 =item full_buffer
327
328 This is an array reference containing all the output the command
329 generated.
330 Note that buffers are only available if you have L<IPC::Run> installed,
331 or if your system is able to work with L<IPC::Open3> -- see below).
332 Otherwise, this element will be C<undef>.
333
334 =item out_buffer
335
336 This is an array reference containing all the output sent to STDOUT the
337 command generated. The notes from L<"full_buffer"> apply.
338
339 =item error_buffer
340
341 This is an arrayreference containing all the output sent to STDERR the
342 command generated. The notes from L<"full_buffer"> apply.
343
344
345 =back
346
347 See the L<"HOW IT WORKS"> section below to see how C<IPC::Cmd> decides
348 what modules or function calls to use when issuing a command.
349
350 =cut
351
352 {   my @acc = qw[ok error _fds];
353
354     ### autogenerate accessors ###
355     for my $key ( @acc ) {
356         no strict 'refs';
357         *{__PACKAGE__."::$key"} = sub {
358             $_[0]->{$key} = $_[1] if @_ > 1;
359             return $_[0]->{$key};
360         }
361     }
362 }
363
364 sub can_use_run_forked {
365     return $CAN_USE_RUN_FORKED eq "1";
366 }
367
368 sub get_monotonic_time {
369     if ($HAVE_MONOTONIC) {
370         return Time::HiRes::clock_gettime(&Time::HiRes::CLOCK_MONOTONIC);
371     }
372     else {
373         return time();
374     }
375 }
376
377 sub adjust_monotonic_start_time {
378     my ($ref_vars, $now, $previous) = @_;
379
380     # workaround only for those systems which don't have
381     # Time::HiRes::CLOCK_MONOTONIC (Mac OSX in particular)
382     return if $HAVE_MONOTONIC;
383
384     # don't have previous monotonic value (only happens once
385     # in the beginning of the program execution)
386     return unless $previous;
387
388     my $time_diff = $now - $previous;
389
390     # adjust previously saved time with the skew value which is
391     # either negative when clock moved back or more than 5 seconds --
392     # assuming that event loop does happen more often than once
393     # per five seconds, which might not be always true (!) but
394     # hopefully that's ok, because it's just a workaround
395     if ($time_diff > 5 || $time_diff < 0) {
396         foreach my $ref_var (@{$ref_vars}) {
397             if (defined($$ref_var)) {
398                 $$ref_var = $$ref_var + $time_diff;
399             }
400         }
401     }
402 }
403
404 sub uninstall_signals {
405                 return unless defined($IPC::Cmd::{'__old_signals'});
406
407                 foreach my $sig_name (keys %{$IPC::Cmd::{'__old_signals'}}) {
408                                 $SIG{$sig_name} = $IPC::Cmd::{'__old_signals'}->{$sig_name};
409                 }
410 }
411
412 # incompatible with POSIX::SigAction
413 #
414 sub install_layered_signal {
415   my ($s, $handler_code) = @_;
416
417   my %available_signals = map {$_ => 1} keys %SIG;
418
419   Carp::confess("install_layered_signal got nonexistent signal name [$s]")
420     unless defined($available_signals{$s});
421   Carp::confess("install_layered_signal expects coderef")
422     if !ref($handler_code) || ref($handler_code) ne 'CODE';
423
424   $IPC::Cmd::{'__old_signals'} = {}
425                 unless defined($IPC::Cmd::{'__old_signals'});
426         $IPC::Cmd::{'__old_signals'}->{$s} = $SIG{$s};
427
428   my $previous_handler = $SIG{$s};
429
430   my $sig_handler = sub {
431     my ($called_sig_name, @sig_param) = @_;
432
433     # $s is a closure referring to real signal name
434     # for which this handler is being installed.
435     # it is used to distinguish between
436     # real signal handlers and aliased signal handlers
437     my $signal_name = $s;
438
439     # $called_sig_name is a signal name which
440     # was passed to this signal handler;
441     # it doesn't equal $signal_name in case
442     # some signal handlers in %SIG point
443     # to other signal handler (CHLD and CLD,
444     # ABRT and IOT)
445     #
446     # initial signal handler for aliased signal
447     # calls some other signal handler which
448     # should not execute the same handler_code again
449     if ($called_sig_name eq $signal_name) {
450       $handler_code->($signal_name);
451     }
452
453     # run original signal handler if any (including aliased)
454     #
455     if (ref($previous_handler)) {
456       $previous_handler->($called_sig_name, @sig_param);
457     }
458   };
459
460   $SIG{$s} = $sig_handler;
461 }
462
463 # give process a chance sending TERM,
464 # waiting for a while (2 seconds)
465 # and killing it with KILL
466 sub kill_gently {
467   my ($pid, $opts) = @_;
468
469   require POSIX;
470
471   $opts = {} unless $opts;
472   $opts->{'wait_time'} = 2 unless defined($opts->{'wait_time'});
473   $opts->{'first_kill_type'} = 'just_process' unless $opts->{'first_kill_type'};
474   $opts->{'final_kill_type'} = 'just_process' unless $opts->{'final_kill_type'};
475
476   if ($opts->{'first_kill_type'} eq 'just_process') {
477     kill(15, $pid);
478   }
479   elsif ($opts->{'first_kill_type'} eq 'process_group') {
480     kill(-15, $pid);
481   }
482
483   my $do_wait = 1;
484   my $child_finished = 0;
485
486   my $wait_start_time = get_monotonic_time();
487   my $now;
488   my $previous_monotonic_value;
489
490   while ($do_wait) {
491     $previous_monotonic_value = $now;
492     $now = get_monotonic_time();
493     
494     adjust_monotonic_start_time([\$wait_start_time], $now, $previous_monotonic_value);
495
496     if ($now > $wait_start_time + $opts->{'wait_time'}) {
497         $do_wait = 0;
498         next;
499     }
500
501     my $waitpid = waitpid($pid, POSIX::WNOHANG);
502
503     if ($waitpid eq -1) {
504         $child_finished = 1;
505         $do_wait = 0;
506         next;
507     }
508     
509     Time::HiRes::usleep(250000); # quarter of a second
510   }
511
512   if (!$child_finished) {
513     if ($opts->{'final_kill_type'} eq 'just_process') {
514       kill(9, $pid);
515     }
516     elsif ($opts->{'final_kill_type'} eq 'process_group') {
517       kill(-9, $pid);
518     }
519   }
520 }
521
522 sub open3_run {
523     my ($cmd, $opts) = @_;
524
525     $opts = {} unless $opts;
526
527     my $child_in = FileHandle->new;
528     my $child_out = FileHandle->new;
529     my $child_err = FileHandle->new;
530     $child_out->autoflush(1);
531     $child_err->autoflush(1);
532
533     my $pid = open3($child_in, $child_out, $child_err, $cmd);
534
535     # push my child's pid to our parent
536     # so in case i am killed parent
537     # could stop my child (search for
538     # child_child_pid in parent code)
539     if ($opts->{'parent_info'}) {
540       my $ps = $opts->{'parent_info'};
541       print $ps "spawned $pid\n";
542     }
543
544     if ($child_in && $child_out->opened && $opts->{'child_stdin'}) {
545         # If the child process dies for any reason,
546         # the next write to CHLD_IN is likely to generate
547         # a SIGPIPE in the parent, which is fatal by default.
548         # So you may wish to handle this signal.
549         #
550         # from http://perldoc.perl.org/IPC/Open3.html,
551         # absolutely needed to catch piped commands errors.
552         #
553         local $SIG{'PIPE'} = sub { 1; };
554
555         print $child_in $opts->{'child_stdin'};
556     }
557     close($child_in);
558
559     my $child_output = {
560         'out' => $child_out->fileno,
561         'err' => $child_err->fileno,
562         $child_out->fileno => {
563             'parent_socket' => $opts->{'parent_stdout'},
564             'scalar_buffer' => "",
565             'child_handle' => $child_out,
566             'block_size' => ($child_out->stat)[11] || 1024,
567           },
568         $child_err->fileno => {
569             'parent_socket' => $opts->{'parent_stderr'},
570             'scalar_buffer' => "",
571             'child_handle' => $child_err,
572             'block_size' => ($child_err->stat)[11] || 1024,
573           },
574         };
575
576     my $select = IO::Select->new();
577     $select->add($child_out, $child_err);
578
579     # pass any signal to the child
580     # effectively creating process
581     # strongly attached to the child:
582     # it will terminate only after child
583     # has terminated (except for SIGKILL,
584     # which is specially handled)
585     SIGNAL: foreach my $s (keys %SIG) {
586         next SIGNAL if $s eq '__WARN__' or $s eq '__DIE__'; # Skip and don't clobber __DIE__ & __WARN__
587         my $sig_handler;
588         $sig_handler = sub {
589             kill("$s", $pid);
590             $SIG{$s} = $sig_handler;
591         };
592         $SIG{$s} = $sig_handler;
593     }
594
595     my $child_finished = 0;
596
597     my $real_exit;
598     my $exit_value;
599
600     while(!$child_finished) {
601
602         # parent was killed otherwise we would have got
603         # the same signal as parent and process it same way
604         if (getppid() eq "1") {
605
606           # end my process group with all the children
607           # (i am the process group leader, so my pid
608           # equals to the process group id)
609           #
610           # same thing which is done
611           # with $opts->{'clean_up_children'}
612           # in run_forked
613           #
614           kill(-9, $$);
615
616           POSIX::_exit 1;
617         }
618
619         my $waitpid = waitpid($pid, POSIX::WNOHANG);
620
621         # child finished, catch it's exit status
622         if ($waitpid ne 0 && $waitpid ne -1) {
623           $real_exit = $?;
624           $exit_value = $? >> 8;
625         }
626
627         if ($waitpid eq -1) {
628           $child_finished = 1;
629         }
630
631
632         my $ready_fds = [];
633         push @{$ready_fds}, $select->can_read(1/100);
634
635         READY_FDS: while (scalar(@{$ready_fds})) {
636             my $fd = shift @{$ready_fds};
637             $ready_fds = [grep {$_ ne $fd} @{$ready_fds}];
638
639             my $str = $child_output->{$fd->fileno};
640             Carp::confess("child stream not found: $fd") unless $str;
641
642             my $data;
643             my $count = $fd->sysread($data, $str->{'block_size'});
644
645             if ($count) {
646                 if ($str->{'parent_socket'}) {
647                     my $ph = $str->{'parent_socket'};
648                     print $ph $data;
649                 }
650                 else {
651                     $str->{'scalar_buffer'} .= $data;
652                 }
653             }
654             elsif ($count eq 0) {
655                 $select->remove($fd);
656                 $fd->close();
657             }
658             else {
659                 Carp::confess("error during sysread: " . $!);
660             }
661
662             push @{$ready_fds}, $select->can_read(1/100) if $child_finished;
663         }
664
665         Time::HiRes::usleep(1);
666     }
667
668     # since we've successfully reaped the child,
669     # let our parent know about this.
670     #
671     if ($opts->{'parent_info'}) {
672         my $ps = $opts->{'parent_info'};
673
674         # child was killed, inform parent
675         if ($real_exit & 127) {
676           print $ps "$pid killed with " . ($real_exit & 127) . "\n";
677         }
678
679         print $ps "reaped $pid\n";
680     }
681
682     if ($opts->{'parent_stdout'} || $opts->{'parent_stderr'}) {
683         return $exit_value;
684     }
685     else {
686         return {
687             'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'},
688             'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'},
689             'exit_code' => $exit_value,
690             };
691     }
692 }
693
694 =head2 $hashref = run_forked( COMMAND, { child_stdin => SCALAR, timeout => DIGIT, stdout_handler => CODEREF, stderr_handler => CODEREF} );
695
696 C<run_forked> is used to execute some program or a coderef,
697 optionally feed it with some input, get its return code
698 and output (both stdout and stderr into separate buffers).
699 In addition, it allows to terminate the program
700 if it takes too long to finish.
701
702 The important and distinguishing feature of run_forked
703 is execution timeout which at first seems to be
704 quite a simple task but if you think
705 that the program which you're spawning
706 might spawn some children itself (which
707 in their turn could do the same and so on)
708 it turns out to be not a simple issue.
709
710 C<run_forked> is designed to survive and
711 successfully terminate almost any long running task,
712 even a fork bomb in case your system has the resources
713 to survive during given timeout.
714
715 This is achieved by creating separate watchdog process
716 which spawns the specified program in a separate
717 process session and supervises it: optionally
718 feeds it with input, stores its exit code,
719 stdout and stderr, terminates it in case
720 it runs longer than specified.
721
722 Invocation requires the command to be executed or a coderef and optionally a hashref of options:
723
724 =over
725
726 =item C<timeout>
727
728 Specify in seconds how long to run the command before it is killed with SIG_KILL (9),
729 which effectively terminates it and all of its children (direct or indirect).
730
731 =item C<child_stdin>
732
733 Specify some text that will be passed into the C<STDIN> of the executed program.
734
735 =item C<stdout_handler>
736
737 Coderef of a subroutine to call when a portion of data is received on
738 STDOUT from the executing program.
739
740 =item C<stderr_handler>
741
742 Coderef of a subroutine to call when a portion of data is received on
743 STDERR from the executing program.
744
745
746 =item C<discard_output>
747
748 Discards the buffering of the standard output and standard errors for return by run_forked().
749 With this option you have to use the std*_handlers to read what the command outputs.
750 Useful for commands that send a lot of output.
751
752 =item C<terminate_on_parent_sudden_death>
753
754 Enable this option if you wish all spawned processes to be killed if the initially spawned
755 process (the parent) is killed or dies without waiting for child processes.
756
757 =back
758
759 C<run_forked> will return a HASHREF with the following keys:
760
761 =over
762
763 =item C<exit_code>
764
765 The exit code of the executed program.
766
767 =item C<timeout>
768
769 The number of seconds the program ran for before being terminated, or 0 if no timeout occurred.
770
771 =item C<stdout>
772
773 Holds the standard output of the executed command (or empty string if
774 there was no STDOUT output or if C<discard_output> was used; it's always defined!)
775
776 =item C<stderr>
777
778 Holds the standard error of the executed command (or empty string if
779 there was no STDERR output or if C<discard_output> was used; it's always defined!)
780
781 =item C<merged>
782
783 Holds the standard output and error of the executed command merged into one stream
784 (or empty string if there was no output at all or if C<discard_output> was used; it's always defined!)
785
786 =item C<err_msg>
787
788 Holds some explanation in the case of an error.
789
790 =back
791
792 =cut
793
794 sub run_forked {
795     ### container to store things in
796     my $self = bless {}, __PACKAGE__;
797
798     if (!can_use_run_forked()) {
799         Carp::carp("run_forked is not available: $CAN_USE_RUN_FORKED");
800         return;
801     }
802
803     require POSIX;
804
805     my ($cmd, $opts) = @_;
806     if (ref($cmd) eq 'ARRAY') {
807         $cmd = join(" ", @{$cmd});
808     }
809
810     if (!$cmd) {
811         Carp::carp("run_forked expects command to run");
812         return;
813     }
814
815     $opts = {} unless $opts;
816     $opts->{'timeout'} = 0 unless $opts->{'timeout'};
817     $opts->{'terminate_wait_time'} = 2 unless defined($opts->{'terminate_wait_time'});
818
819     # turned on by default
820     $opts->{'clean_up_children'} = 1 unless defined($opts->{'clean_up_children'});
821
822     # sockets to pass child stdout to parent
823     my $child_stdout_socket;
824     my $parent_stdout_socket;
825
826     # sockets to pass child stderr to parent
827     my $child_stderr_socket;
828     my $parent_stderr_socket;
829
830     # sockets for child -> parent internal communication
831     my $child_info_socket;
832     my $parent_info_socket;
833
834     socketpair($child_stdout_socket, $parent_stdout_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
835       Carp::confess ("socketpair: $!");
836     socketpair($child_stderr_socket, $parent_stderr_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
837       Carp::confess ("socketpair: $!");
838     socketpair($child_info_socket, $parent_info_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
839       Carp::confess ("socketpair: $!");
840
841     $child_stdout_socket->autoflush(1);
842     $parent_stdout_socket->autoflush(1);
843     $child_stderr_socket->autoflush(1);
844     $parent_stderr_socket->autoflush(1);
845     $child_info_socket->autoflush(1);
846     $parent_info_socket->autoflush(1);
847
848     my $start_time = get_monotonic_time();
849
850     my $pid;
851     if ($pid = fork) {
852
853       # we are a parent
854       close($parent_stdout_socket);
855       close($parent_stderr_socket);
856       close($parent_info_socket);
857
858       my $flags;
859
860       # prepare sockets to read from child
861
862       $flags = fcntl($child_stdout_socket, POSIX::F_GETFL, 0) || Carp::confess "can't fnctl F_GETFL: $!";
863       $flags |= POSIX::O_NONBLOCK;
864       fcntl($child_stdout_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!";
865
866       $flags = fcntl($child_stderr_socket, POSIX::F_GETFL, 0) || Carp::confess "can't fnctl F_GETFL: $!";
867       $flags |= POSIX::O_NONBLOCK;
868       fcntl($child_stderr_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!";
869
870       $flags = fcntl($child_info_socket, POSIX::F_GETFL, 0) || Carp::confess "can't fnctl F_GETFL: $!";
871       $flags |= POSIX::O_NONBLOCK;
872       fcntl($child_info_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!";
873
874   #    print "child $pid started\n";
875
876       my $child_output = {
877         $child_stdout_socket->fileno => {
878           'scalar_buffer' => "",
879           'child_handle' => $child_stdout_socket,
880           'block_size' => ($child_stdout_socket->stat)[11] || 1024,
881           'protocol' => 'stdout',
882           },
883         $child_stderr_socket->fileno => {
884           'scalar_buffer' => "",
885           'child_handle' => $child_stderr_socket,
886           'block_size' => ($child_stderr_socket->stat)[11] || 1024,
887           'protocol' => 'stderr',
888           },
889         $child_info_socket->fileno => {
890           'scalar_buffer' => "",
891           'child_handle' => $child_info_socket,
892           'block_size' => ($child_info_socket->stat)[11] || 1024,
893           'protocol' => 'info',
894           },
895         };
896
897       my $select = IO::Select->new();
898       $select->add($child_stdout_socket, $child_stderr_socket, $child_info_socket);
899
900       my $child_timedout = 0;
901       my $child_finished = 0;
902       my $child_stdout = '';
903       my $child_stderr = '';
904       my $child_merged = '';
905       my $child_exit_code = 0;
906       my $child_killed_by_signal = 0;
907       my $parent_died = 0;
908
909       my $last_parent_check = 0;
910       my $got_sig_child = 0;
911       my $got_sig_quit = 0;
912       my $orig_sig_child = $SIG{'CHLD'};
913
914       $SIG{'CHLD'} = sub { $got_sig_child = get_monotonic_time(); };
915
916       if ($opts->{'terminate_on_signal'}) {
917         install_layered_signal($opts->{'terminate_on_signal'}, sub { $got_sig_quit = time(); });
918       }
919
920       my $child_child_pid;
921       my $now;
922       my $previous_monotonic_value;
923
924       while (!$child_finished) {
925         $previous_monotonic_value = $now;
926         $now = get_monotonic_time();
927
928         adjust_monotonic_start_time([\$start_time, \$last_parent_check, \$got_sig_child], $now, $previous_monotonic_value);
929
930         if ($opts->{'terminate_on_parent_sudden_death'}) {
931           # check for parent once each five seconds
932           if ($now > $last_parent_check + 5) {
933             if (getppid() eq "1") {
934               kill_gently ($pid, {
935                 'first_kill_type' => 'process_group',
936                 'final_kill_type' => 'process_group',
937                 'wait_time' => $opts->{'terminate_wait_time'}
938                 });
939               $parent_died = 1;
940             }
941
942             $last_parent_check = $now;
943           }
944         }
945
946         # user specified timeout
947         if ($opts->{'timeout'}) {
948           if ($now > $start_time + $opts->{'timeout'}) {
949             kill_gently ($pid, {
950               'first_kill_type' => 'process_group',
951               'final_kill_type' => 'process_group',
952               'wait_time' => $opts->{'terminate_wait_time'}
953               });
954             $child_timedout = 1;
955           }
956         }
957
958         # give OS 10 seconds for correct return of waitpid,
959         # kill process after that and finish wait loop;
960         # shouldn't ever happen -- remove this code?
961         if ($got_sig_child) {
962           if ($now > $got_sig_child + 10) {
963             print STDERR "waitpid did not return -1 for 10 seconds after SIG_CHLD, killing [$pid]\n";
964             kill (-9, $pid);
965             $child_finished = 1;
966           }
967         }
968
969         if ($got_sig_quit) {
970           kill_gently ($pid, {
971             'first_kill_type' => 'process_group',
972             'final_kill_type' => 'process_group',
973             'wait_time' => $opts->{'terminate_wait_time'}
974             });
975           $child_finished = 1;
976         }
977
978         my $waitpid = waitpid($pid, POSIX::WNOHANG);
979
980         # child finished, catch it's exit status
981         if ($waitpid ne 0 && $waitpid ne -1) {
982           $child_exit_code = $? >> 8;
983         }
984
985         if ($waitpid eq -1) {
986           $child_finished = 1;
987         }
988
989         my $ready_fds = [];
990         push @{$ready_fds}, $select->can_read(1/100);
991
992         READY_FDS: while (scalar(@{$ready_fds})) {
993           my $fd = shift @{$ready_fds};
994           $ready_fds = [grep {$_ ne $fd} @{$ready_fds}];
995
996           my $str = $child_output->{$fd->fileno};
997           Carp::confess("child stream not found: $fd") unless $str;
998
999           my $data = "";
1000           my $count = $fd->sysread($data, $str->{'block_size'});
1001
1002           if ($count) {
1003               # extract all the available lines and store the rest in temporary buffer
1004               if ($data =~ /(.+\n)([^\n]*)/so) {
1005                   $data = $str->{'scalar_buffer'} . $1;
1006                   $str->{'scalar_buffer'} = $2 || "";
1007               }
1008               else {
1009                   $str->{'scalar_buffer'} .= $data;
1010                   $data = "";
1011               }
1012           }
1013           elsif ($count eq 0) {
1014             $select->remove($fd);
1015             $fd->close();
1016             if ($str->{'scalar_buffer'}) {
1017                 $data = $str->{'scalar_buffer'} . "\n";
1018             }
1019           }
1020           else {
1021             Carp::confess("error during sysread on [$fd]: " . $!);
1022           }
1023
1024           # $data contains only full lines (or last line if it was unfinished read
1025           # or now new-line in the output of the child); dat is processed
1026           # according to the "protocol" of socket
1027           if ($str->{'protocol'} eq 'info') {
1028             if ($data =~ /^spawned ([0-9]+?)\n(.*?)/so) {
1029               $child_child_pid = $1;
1030               $data = $2;
1031             }
1032             if ($data =~ /^reaped ([0-9]+?)\n(.*?)/so) {
1033               $child_child_pid = undef;
1034               $data = $2;
1035             }
1036             if ($data =~ /^[\d]+ killed with ([0-9]+?)\n(.*?)/so) {
1037               $child_killed_by_signal = $1;
1038               $data = $2;
1039             }
1040
1041             # we don't expect any other data in info socket, so it's
1042             # some strange violation of protocol, better know about this
1043             if ($data) {
1044               Carp::confess("info protocol violation: [$data]");
1045             }
1046           }
1047           if ($str->{'protocol'} eq 'stdout') {
1048             if (!$opts->{'discard_output'}) {
1049               $child_stdout .= $data;
1050               $child_merged .= $data;
1051             }
1052
1053             if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') {
1054               $opts->{'stdout_handler'}->($data);
1055             }
1056           }
1057           if ($str->{'protocol'} eq 'stderr') {
1058             if (!$opts->{'discard_output'}) {
1059               $child_stderr .= $data;
1060               $child_merged .= $data;
1061             }
1062
1063             if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') {
1064               $opts->{'stderr_handler'}->($data);
1065             }
1066           }
1067  
1068           # process may finish (waitpid returns -1) before
1069           # we've read all of its output because of buffering;
1070           # so try to read all the way it is possible to read
1071           # in such case - this shouldn't be too much (unless
1072           # the buffer size is HUGE -- should introduce
1073           # another counter in such case, maybe later)
1074           #
1075           push @{$ready_fds}, $select->can_read(1/100) if $child_finished;
1076         }
1077
1078         Time::HiRes::usleep(1);
1079       }
1080
1081       # $child_pid_pid is not defined in two cases:
1082       #  * when our child was killed before
1083       #    it had chance to tell us the pid
1084       #    of the child it spawned. we can do
1085       #    nothing in this case :(
1086       #  * our child successfully reaped its child,
1087       #    we have nothing left to do in this case
1088       #
1089       # defined $child_pid_pid means child's child
1090       # has not died but nobody is waiting for it,
1091       # killing it brutally.
1092       #
1093       if ($child_child_pid) {
1094         kill_gently($child_child_pid);
1095       }
1096
1097       # in case there are forks in child which
1098       # do not forward or process signals (TERM) correctly
1099       # kill whole child process group, effectively trying
1100       # not to return with some children or their parts still running
1101       #
1102       # to be more accurate -- we need to be sure
1103       # that this is process group created by our child
1104       # (and not some other process group with the same pgid,
1105       # created just after death of our child) -- fortunately
1106       # this might happen only when process group ids
1107       # are reused quickly (there are lots of processes
1108       # spawning new process groups for example)
1109       #
1110       if ($opts->{'clean_up_children'}) {
1111         kill(-9, $pid);
1112       }
1113
1114   #    print "child $pid finished\n";
1115
1116       close($child_stdout_socket);
1117       close($child_stderr_socket);
1118       close($child_info_socket);
1119
1120       my $o = {
1121         'stdout' => $child_stdout,
1122         'stderr' => $child_stderr,
1123         'merged' => $child_merged,
1124         'timeout' => $child_timedout ? $opts->{'timeout'} : 0,
1125         'exit_code' => $child_exit_code,
1126         'parent_died' => $parent_died,
1127         'killed_by_signal' => $child_killed_by_signal,
1128         'child_pgid' => $pid,
1129         'cmd' => $cmd,
1130         };
1131
1132       my $err_msg = '';
1133       if ($o->{'exit_code'}) {
1134         $err_msg .= "exited with code [$o->{'exit_code'}]\n";
1135       }
1136       if ($o->{'timeout'}) {
1137         $err_msg .= "ran more than [$o->{'timeout'}] seconds\n";
1138       }
1139       if ($o->{'parent_died'}) {
1140         $err_msg .= "parent died\n";
1141       }
1142       if ($o->{'stdout'} && !$opts->{'non_empty_stdout_ok'}) {
1143         $err_msg .= "stdout:\n" . $o->{'stdout'} . "\n";
1144       }
1145       if ($o->{'stderr'}) {
1146         $err_msg .= "stderr:\n" . $o->{'stderr'} . "\n";
1147       }
1148       if ($o->{'killed_by_signal'}) {
1149         $err_msg .= "killed by signal [" . $o->{'killed_by_signal'} . "]\n";
1150       }
1151       $o->{'err_msg'} = $err_msg;
1152
1153       if ($orig_sig_child) {
1154         $SIG{'CHLD'} = $orig_sig_child;
1155       }
1156       else {
1157         delete($SIG{'CHLD'});
1158       }
1159
1160       uninstall_signals();
1161
1162       return $o;
1163     }
1164     else {
1165       Carp::confess("cannot fork: $!") unless defined($pid);
1166
1167       # create new process session for open3 call,
1168       # so we hopefully can kill all the subprocesses
1169       # which might be spawned in it (except for those
1170       # which do setsid theirselves -- can't do anything
1171       # with those)
1172
1173       POSIX::setsid() || Carp::confess("Error running setsid: " . $!);
1174
1175       if ($opts->{'child_BEGIN'} && ref($opts->{'child_BEGIN'}) eq 'CODE') {
1176         $opts->{'child_BEGIN'}->();
1177       }
1178
1179       close($child_stdout_socket);
1180       close($child_stderr_socket);
1181       close($child_info_socket);
1182
1183       my $child_exit_code;
1184
1185       # allow both external programs
1186       # and internal perl calls
1187       if (!ref($cmd)) {
1188         $child_exit_code = open3_run($cmd, {
1189           'parent_info' => $parent_info_socket,
1190           'parent_stdout' => $parent_stdout_socket,
1191           'parent_stderr' => $parent_stderr_socket,
1192           'child_stdin' => $opts->{'child_stdin'},
1193           });
1194       }
1195       elsif (ref($cmd) eq 'CODE') {
1196         # reopen STDOUT and STDERR for child code:
1197         # https://rt.cpan.org/Ticket/Display.html?id=85912
1198         open STDOUT, '>&', $parent_stdout_socket || Carp::confess("Unable to reopen STDOUT: $!\n");
1199         open STDERR, '>&', $parent_stderr_socket || Carp::confess("Unable to reopen STDERR: $!\n");
1200
1201         $child_exit_code = $cmd->({
1202           'opts' => $opts,
1203           'parent_info' => $parent_info_socket,
1204           'parent_stdout' => $parent_stdout_socket,
1205           'parent_stderr' => $parent_stderr_socket,
1206           'child_stdin' => $opts->{'child_stdin'},
1207           });
1208       }
1209       else {
1210         print $parent_stderr_socket "Invalid command reference: " . ref($cmd) . "\n";
1211         $child_exit_code = 1;
1212       }
1213
1214       close($parent_stdout_socket);
1215       close($parent_stderr_socket);
1216       close($parent_info_socket);
1217
1218       if ($opts->{'child_END'} && ref($opts->{'child_END'}) eq 'CODE') {
1219         $opts->{'child_END'}->();
1220       }
1221
1222       $| = 1;
1223       POSIX::_exit $child_exit_code;
1224     }
1225 }
1226
1227 sub run {
1228     ### container to store things in
1229     my $self = bless {}, __PACKAGE__;
1230
1231     my %hash = @_;
1232
1233     ### if the user didn't provide a buffer, we'll store it here.
1234     my $def_buf = '';
1235
1236     my($verbose,$cmd,$buffer,$timeout);
1237     my $tmpl = {
1238         verbose => { default  => $VERBOSE,  store => \$verbose },
1239         buffer  => { default  => \$def_buf, store => \$buffer },
1240         command => { required => 1,         store => \$cmd,
1241                      allow    => sub { !ref($_[0]) or ref($_[0]) eq 'ARRAY' },
1242         },
1243         timeout => { default  => 0,         store => \$timeout },
1244     };
1245
1246     unless( check( $tmpl, \%hash, $VERBOSE ) ) {
1247         Carp::carp( loc( "Could not validate input: %1",
1248                          Params::Check->last_error ) );
1249         return;
1250     };
1251
1252     $cmd = _quote_args_vms( $cmd ) if IS_VMS;
1253
1254     ### strip any empty elements from $cmd if present
1255     if ( $ALLOW_NULL_ARGS ) {
1256       $cmd = [ grep { defined } @$cmd ] if ref $cmd;
1257     }
1258     else {
1259       $cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
1260     }
1261
1262     my $pp_cmd = (ref $cmd ? "@$cmd" : $cmd);
1263     print loc("Running [%1]...\n", $pp_cmd ) if $verbose;
1264
1265     ### did the user pass us a buffer to fill or not? if so, set this
1266     ### flag so we know what is expected of us
1267     ### XXX this is now being ignored. in the future, we could add diagnostic
1268     ### messages based on this logic
1269     #my $user_provided_buffer = $buffer == \$def_buf ? 0 : 1;
1270
1271     ### buffers that are to be captured
1272     my( @buffer, @buff_err, @buff_out );
1273
1274     ### capture STDOUT
1275     my $_out_handler = sub {
1276         my $buf = shift;
1277         return unless defined $buf;
1278
1279         print STDOUT $buf if $verbose;
1280         push @buffer,   $buf;
1281         push @buff_out, $buf;
1282     };
1283
1284     ### capture STDERR
1285     my $_err_handler = sub {
1286         my $buf = shift;
1287         return unless defined $buf;
1288
1289         print STDERR $buf if $verbose;
1290         push @buffer,   $buf;
1291         push @buff_err, $buf;
1292     };
1293
1294
1295     ### flag to indicate we have a buffer captured
1296     my $have_buffer = $self->can_capture_buffer ? 1 : 0;
1297
1298     ### flag indicating if the subcall went ok
1299     my $ok;
1300
1301     ### don't look at previous errors:
1302     local $?;
1303     local $@;
1304     local $!;
1305
1306     ### we might be having a timeout set
1307     eval {
1308         local $SIG{ALRM} = sub { die bless sub {
1309             ALARM_CLASS .
1310             qq[: Command '$pp_cmd' aborted by alarm after $timeout seconds]
1311         }, ALARM_CLASS } if $timeout;
1312         alarm $timeout || 0;
1313
1314         ### IPC::Run is first choice if $USE_IPC_RUN is set.
1315         if( !IS_WIN32 and $USE_IPC_RUN and $self->can_use_ipc_run( 1 ) ) {
1316             ### ipc::run handlers needs the command as a string or an array ref
1317
1318             $self->_debug( "# Using IPC::Run. Have buffer: $have_buffer" )
1319                 if $DEBUG;
1320
1321             $ok = $self->_ipc_run( $cmd, $_out_handler, $_err_handler );
1322
1323         ### since IPC::Open3 works on all platforms, and just fails on
1324         ### win32 for capturing buffers, do that ideally
1325         } elsif ( $USE_IPC_OPEN3 and $self->can_use_ipc_open3( 1 ) ) {
1326
1327             $self->_debug("# Using IPC::Open3. Have buffer: $have_buffer")
1328                 if $DEBUG;
1329
1330             ### in case there are pipes in there;
1331             ### IPC::Open3 will call exec and exec will do the right thing
1332
1333             my $method = IS_WIN32 ? '_open3_run_win32' : '_open3_run';
1334
1335             $ok = $self->$method(
1336                                     $cmd, $_out_handler, $_err_handler, $verbose
1337                                 );
1338
1339         ### if we are allowed to run verbose, just dispatch the system command
1340         } else {
1341             $self->_debug( "# Using system(). Have buffer: $have_buffer" )
1342                 if $DEBUG;
1343             $ok = $self->_system_run( $cmd, $verbose );
1344         }
1345
1346         alarm 0;
1347     };
1348
1349     ### restore STDIN after duping, or STDIN will be closed for
1350     ### this current perl process!
1351     $self->__reopen_fds( @{ $self->_fds} ) if $self->_fds;
1352
1353     my $err;
1354     unless( $ok ) {
1355         ### alarm happened
1356         if ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) {
1357             $err = $@->();  # the error code is an expired alarm
1358
1359         ### another error happened, set by the dispatchub
1360         } else {
1361             $err = $self->error;
1362         }
1363     }
1364
1365     ### fill the buffer;
1366     $$buffer = join '', @buffer if @buffer;
1367
1368     ### return a list of flags and buffers (if available) in list
1369     ### context, or just a simple 'ok' in scalar
1370     return wantarray
1371                 ? $have_buffer
1372                     ? ($ok, $err, \@buffer, \@buff_out, \@buff_err)
1373                     : ($ok, $err )
1374                 : $ok
1375
1376
1377 }
1378
1379 sub _open3_run_win32 {
1380   my $self    = shift;
1381   my $cmd     = shift;
1382   my $outhand = shift;
1383   my $errhand = shift;
1384
1385   require Socket;
1386
1387   my $pipe = sub {
1388     socketpair($_[0], $_[1], &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC)
1389         or return undef;
1390     shutdown($_[0], 1);  # No more writing for reader
1391     shutdown($_[1], 0);  # No more reading for writer
1392     return 1;
1393   };
1394
1395   my $open3 = sub {
1396     local (*TO_CHLD_R,     *TO_CHLD_W);
1397     local (*FR_CHLD_R,     *FR_CHLD_W);
1398     local (*FR_CHLD_ERR_R, *FR_CHLD_ERR_W);
1399
1400     $pipe->(*TO_CHLD_R,     *TO_CHLD_W    ) or die $^E;
1401     $pipe->(*FR_CHLD_R,     *FR_CHLD_W    ) or die $^E;
1402     $pipe->(*FR_CHLD_ERR_R, *FR_CHLD_ERR_W) or die $^E;
1403
1404     my $pid = IPC::Open3::open3('>&TO_CHLD_R', '<&FR_CHLD_W', '<&FR_CHLD_ERR_W', @_);
1405
1406     return ( $pid, *TO_CHLD_W, *FR_CHLD_R, *FR_CHLD_ERR_R );
1407   };
1408
1409   $cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
1410   $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
1411
1412   my ($pid, $to_chld, $fr_chld, $fr_chld_err) =
1413     $open3->( ( ref $cmd ? @$cmd : $cmd ) );
1414
1415   my $in_sel  = IO::Select->new();
1416   my $out_sel = IO::Select->new();
1417
1418   my %objs;
1419
1420   $objs{ fileno( $fr_chld ) } = $outhand;
1421   $objs{ fileno( $fr_chld_err ) } = $errhand;
1422   $in_sel->add( $fr_chld );
1423   $in_sel->add( $fr_chld_err );
1424
1425   close($to_chld);
1426
1427   while ($in_sel->count() + $out_sel->count()) {
1428     my ($ins, $outs) = IO::Select::select($in_sel, $out_sel, undef);
1429
1430     for my $fh (@$ins) {
1431         my $obj = $objs{ fileno($fh) };
1432         my $buf;
1433         my $bytes_read = sysread($fh, $buf, 64*1024 ); #, length($buf));
1434         if (!$bytes_read) {
1435             $in_sel->remove($fh);
1436         }
1437         else {
1438             $obj->( "$buf" );
1439         }
1440       }
1441
1442       for my $fh (@$outs) {
1443       }
1444   }
1445
1446   waitpid($pid, 0);
1447
1448   ### some error occurred
1449   if( $? ) {
1450         $self->error( $self->_pp_child_error( $cmd, $? ) );
1451         $self->ok( 0 );
1452         return;
1453   } else {
1454         return $self->ok( 1 );
1455   }
1456 }
1457
1458 sub _open3_run {
1459     my $self            = shift;
1460     my $cmd             = shift;
1461     my $_out_handler    = shift;
1462     my $_err_handler    = shift;
1463     my $verbose         = shift || 0;
1464
1465     ### Following code are adapted from Friar 'abstracts' in the
1466     ### Perl Monastery (http://www.perlmonks.org/index.pl?node_id=151886).
1467     ### XXX that code didn't work.
1468     ### we now use the following code, thanks to theorbtwo
1469
1470     ### define them beforehand, so we always have defined FH's
1471     ### to read from.
1472     use Symbol;
1473     my $kidout      = Symbol::gensym();
1474     my $kiderror    = Symbol::gensym();
1475
1476     ### Dup the filehandle so we can pass 'our' STDIN to the
1477     ### child process. This stops us from having to pump input
1478     ### from ourselves to the childprocess. However, we will need
1479     ### to revive the FH afterwards, as IPC::Open3 closes it.
1480     ### We'll do the same for STDOUT and STDERR. It works without
1481     ### duping them on non-unix derivatives, but not on win32.
1482     my @fds_to_dup = ( IS_WIN32 && !$verbose
1483                             ? qw[STDIN STDOUT STDERR]
1484                             : qw[STDIN]
1485                         );
1486     $self->_fds( \@fds_to_dup );
1487     $self->__dup_fds( @fds_to_dup );
1488
1489     ### pipes have to come in a quoted string, and that clashes with
1490     ### whitespace. This sub fixes up such commands so they run properly
1491     $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
1492
1493     ### don't stringify @$cmd, so spaces in filenames/paths are
1494     ### treated properly
1495     my $pid = eval {
1496         IPC::Open3::open3(
1497                     '<&STDIN',
1498                     (IS_WIN32 ? '>&STDOUT' : $kidout),
1499                     (IS_WIN32 ? '>&STDERR' : $kiderror),
1500                     ( ref $cmd ? @$cmd : $cmd ),
1501                 );
1502     };
1503
1504     ### open3 error occurred
1505     if( $@ and $@ =~ /^open3:/ ) {
1506         $self->ok( 0 );
1507         $self->error( $@ );
1508         return;
1509     };
1510
1511     ### use OUR stdin, not $kidin. Somehow,
1512     ### we never get the input.. so jump through
1513     ### some hoops to do it :(
1514     my $selector = IO::Select->new(
1515                         (IS_WIN32 ? \*STDERR : $kiderror),
1516                         \*STDIN,
1517                         (IS_WIN32 ? \*STDOUT : $kidout)
1518                     );
1519
1520     STDOUT->autoflush(1);   STDERR->autoflush(1);   STDIN->autoflush(1);
1521     $kidout->autoflush(1)   if UNIVERSAL::can($kidout,   'autoflush');
1522     $kiderror->autoflush(1) if UNIVERSAL::can($kiderror, 'autoflush');
1523
1524     ### add an explicit break statement
1525     ### code courtesy of theorbtwo from #london.pm
1526     my $stdout_done = 0;
1527     my $stderr_done = 0;
1528     OUTER: while ( my @ready = $selector->can_read ) {
1529
1530         for my $h ( @ready ) {
1531             my $buf;
1532
1533             ### $len is the amount of bytes read
1534             my $len = sysread( $h, $buf, 4096 );    # try to read 4096 bytes
1535
1536             ### see perldoc -f sysread: it returns undef on error,
1537             ### so bail out.
1538             if( not defined $len ) {
1539                 warn(loc("Error reading from process: %1", $!));
1540                 last OUTER;
1541             }
1542
1543             ### check for $len. it may be 0, at which point we're
1544             ### done reading, so don't try to process it.
1545             ### if we would print anyway, we'd provide bogus information
1546             $_out_handler->( "$buf" ) if $len && $h == $kidout;
1547             $_err_handler->( "$buf" ) if $len && $h == $kiderror;
1548
1549             ### Wait till child process is done printing to both
1550             ### stdout and stderr.
1551             $stdout_done = 1 if $h == $kidout   and $len == 0;
1552             $stderr_done = 1 if $h == $kiderror and $len == 0;
1553             last OUTER if ($stdout_done && $stderr_done);
1554         }
1555     }
1556
1557     waitpid $pid, 0; # wait for it to die
1558
1559     ### restore STDIN after duping, or STDIN will be closed for
1560     ### this current perl process!
1561     ### done in the parent call now
1562     # $self->__reopen_fds( @fds_to_dup );
1563
1564     ### some error occurred
1565     if( $? ) {
1566         $self->error( $self->_pp_child_error( $cmd, $? ) );
1567         $self->ok( 0 );
1568         return;
1569     } else {
1570         return $self->ok( 1 );
1571     }
1572 }
1573
1574 ### Text::ParseWords::shellwords() uses unix semantics. that will break
1575 ### on win32
1576 {   my $parse_sub = IS_WIN32
1577                         ? __PACKAGE__->can('_split_like_shell_win32')
1578                         : Text::ParseWords->can('shellwords');
1579
1580     sub _ipc_run {
1581         my $self            = shift;
1582         my $cmd             = shift;
1583         my $_out_handler    = shift;
1584         my $_err_handler    = shift;
1585
1586         STDOUT->autoflush(1); STDERR->autoflush(1);
1587
1588         ### a command like:
1589         # [
1590         #     '/usr/bin/gzip',
1591         #     '-cdf',
1592         #     '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz',
1593         #     '|',
1594         #     '/usr/bin/tar',
1595         #     '-tf -'
1596         # ]
1597         ### needs to become:
1598         # [
1599         #     ['/usr/bin/gzip', '-cdf',
1600         #       '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz']
1601         #     '|',
1602         #     ['/usr/bin/tar', '-tf -']
1603         # ]
1604
1605
1606         my @command;
1607         my $special_chars;
1608
1609         my $re = do { my $x = join '', SPECIAL_CHARS; qr/([$x])/ };
1610         if( ref $cmd ) {
1611             my $aref = [];
1612             for my $item (@$cmd) {
1613                 if( $item =~ $re ) {
1614                     push @command, $aref, $item;
1615                     $aref = [];
1616                     $special_chars .= $1;
1617                 } else {
1618                     push @$aref, $item;
1619                 }
1620             }
1621             push @command, $aref;
1622         } else {
1623             @command = map { if( $_ =~ $re ) {
1624                                 $special_chars .= $1; $_;
1625                              } else {
1626 #                                [ split /\s+/ ]
1627                                  [ map { m/[ ]/ ? qq{'$_'} : $_ } $parse_sub->($_) ]
1628                              }
1629                         } split( /\s*$re\s*/, $cmd );
1630         }
1631
1632         ### if there's a pipe in the command, *STDIN needs to
1633         ### be inserted *BEFORE* the pipe, to work on win32
1634         ### this also works on *nix, so we should do it when possible
1635         ### this should *also* work on multiple pipes in the command
1636         ### if there's no pipe in the command, append STDIN to the back
1637         ### of the command instead.
1638         ### XXX seems IPC::Run works it out for itself if you just
1639         ### don't pass STDIN at all.
1640         #     if( $special_chars and $special_chars =~ /\|/ ) {
1641         #         ### only add STDIN the first time..
1642         #         my $i;
1643         #         @command = map { ($_ eq '|' && not $i++)
1644         #                             ? ( \*STDIN, $_ )
1645         #                             : $_
1646         #                         } @command;
1647         #     } else {
1648         #         push @command, \*STDIN;
1649         #     }
1650
1651         # \*STDIN is already included in the @command, see a few lines up
1652         my $ok = eval { IPC::Run::run(   @command,
1653                                 fileno(STDOUT).'>',
1654                                 $_out_handler,
1655                                 fileno(STDERR).'>',
1656                                 $_err_handler
1657                             )
1658                         };
1659
1660         ### all is well
1661         if( $ok ) {
1662             return $self->ok( $ok );
1663
1664         ### some error occurred
1665         } else {
1666             $self->ok( 0 );
1667
1668             ### if the eval fails due to an exception, deal with it
1669             ### unless it's an alarm
1670             if( $@ and not UNIVERSAL::isa( $@, ALARM_CLASS ) ) {
1671                 $self->error( $@ );
1672
1673             ### if it *is* an alarm, propagate
1674             } elsif( $@ ) {
1675                 die $@;
1676
1677             ### some error in the sub command
1678             } else {
1679                 $self->error( $self->_pp_child_error( $cmd, $? ) );
1680             }
1681
1682             return;
1683         }
1684     }
1685 }
1686
1687 sub _system_run {
1688     my $self    = shift;
1689     my $cmd     = shift;
1690     my $verbose = shift || 0;
1691
1692     ### pipes have to come in a quoted string, and that clashes with
1693     ### whitespace. This sub fixes up such commands so they run properly
1694     $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
1695
1696     my @fds_to_dup = $verbose ? () : qw[STDOUT STDERR];
1697     $self->_fds( \@fds_to_dup );
1698     $self->__dup_fds( @fds_to_dup );
1699
1700     ### system returns 'true' on failure -- the exit code of the cmd
1701     $self->ok( 1 );
1702     system( ref $cmd ? @$cmd : $cmd ) == 0 or do {
1703         $self->error( $self->_pp_child_error( $cmd, $? ) );
1704         $self->ok( 0 );
1705     };
1706
1707     ### done in the parent call now
1708     #$self->__reopen_fds( @fds_to_dup );
1709
1710     return unless $self->ok;
1711     return $self->ok;
1712 }
1713
1714 {   my %sc_lookup = map { $_ => $_ } SPECIAL_CHARS;
1715
1716
1717     sub __fix_cmd_whitespace_and_special_chars {
1718         my $self = shift;
1719         my $cmd  = shift;
1720
1721         ### command has a special char in it
1722         if( ref $cmd and grep { $sc_lookup{$_} } @$cmd ) {
1723
1724             ### since we have special chars, we have to quote white space
1725             ### this *may* conflict with the parsing :(
1726             my $fixed;
1727             my @cmd = map { / / ? do { $fixed++; QUOTE.$_.QUOTE } : $_ } @$cmd;
1728
1729             $self->_debug( "# Quoted $fixed arguments containing whitespace" )
1730                     if $DEBUG && $fixed;
1731
1732             ### stringify it, so the special char isn't escaped as argument
1733             ### to the program
1734             $cmd = join ' ', @cmd;
1735         }
1736
1737         return $cmd;
1738     }
1739 }
1740
1741 ### Command-line arguments (but not the command itself) must be quoted
1742 ### to ensure case preservation. Borrowed from Module::Build with adaptations.
1743 ### Patch for this supplied by Craig Berry, see RT #46288: [PATCH] Add argument
1744 ### quoting for run() on VMS
1745 sub _quote_args_vms {
1746   ### Returns a command string with proper quoting so that the subprocess
1747   ### sees this same list of args, or if we get a single arg that is an
1748   ### array reference, quote the elements of it (except for the first)
1749   ### and return the reference.
1750   my @args = @_;
1751   my $got_arrayref = (scalar(@args) == 1
1752                       && UNIVERSAL::isa($args[0], 'ARRAY'))
1753                    ? 1
1754                    : 0;
1755
1756   @args = split(/\s+/, $args[0]) unless $got_arrayref || scalar(@args) > 1;
1757
1758   my $cmd = $got_arrayref ? shift @{$args[0]} : shift @args;
1759
1760   ### Do not quote qualifiers that begin with '/' or previously quoted args.
1761   map { if (/^[^\/\"]/) {
1762           $_ =~ s/\"/""/g;     # escape C<"> by doubling
1763           $_ = q(").$_.q(");
1764         }
1765   }
1766     ($got_arrayref ? @{$args[0]}
1767                    : @args
1768     );
1769
1770   $got_arrayref ? unshift(@{$args[0]}, $cmd) : unshift(@args, $cmd);
1771
1772   return $got_arrayref ? $args[0]
1773                        : join(' ', @args);
1774 }
1775
1776
1777 ### XXX this is cribbed STRAIGHT from M::B 0.30 here:
1778 ### http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell
1779 ### XXX this *should* be integrated into text::parsewords
1780 sub _split_like_shell_win32 {
1781   # As it turns out, Windows command-parsing is very different from
1782   # Unix command-parsing.  Double-quotes mean different things,
1783   # backslashes don't necessarily mean escapes, and so on.  So we
1784   # can't use Text::ParseWords::shellwords() to break a command string
1785   # into words.  The algorithm below was bashed out by Randy and Ken
1786   # (mostly Randy), and there are a lot of regression tests, so we
1787   # should feel free to adjust if desired.
1788
1789   local $_ = shift;
1790
1791   my @argv;
1792   return @argv unless defined() && length();
1793
1794   my $arg = '';
1795   my( $i, $quote_mode ) = ( 0, 0 );
1796
1797   while ( $i < length() ) {
1798
1799     my $ch      = substr( $_, $i  , 1 );
1800     my $next_ch = substr( $_, $i+1, 1 );
1801
1802     if ( $ch eq '\\' && $next_ch eq '"' ) {
1803       $arg .= '"';
1804       $i++;
1805     } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
1806       $arg .= '\\';
1807       $i++;
1808     } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
1809       $quote_mode = !$quote_mode;
1810       $arg .= '"';
1811       $i++;
1812     } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
1813           ( $i + 2 == length()  ||
1814         substr( $_, $i + 2, 1 ) eq ' ' )
1815         ) { # for cases like: a"" => [ 'a' ]
1816       push( @argv, $arg );
1817       $arg = '';
1818       $i += 2;
1819     } elsif ( $ch eq '"' ) {
1820       $quote_mode = !$quote_mode;
1821     } elsif ( $ch eq ' ' && !$quote_mode ) {
1822       push( @argv, $arg ) if defined( $arg ) && length( $arg );
1823       $arg = '';
1824       ++$i while substr( $_, $i + 1, 1 ) eq ' ';
1825     } else {
1826       $arg .= $ch;
1827     }
1828
1829     $i++;
1830   }
1831
1832   push( @argv, $arg ) if defined( $arg ) && length( $arg );
1833   return @argv;
1834 }
1835
1836
1837
1838 {   use File::Spec;
1839     use Symbol;
1840
1841     my %Map = (
1842         STDOUT => [qw|>&|, \*STDOUT, Symbol::gensym() ],
1843         STDERR => [qw|>&|, \*STDERR, Symbol::gensym() ],
1844         STDIN  => [qw|<&|, \*STDIN,  Symbol::gensym() ],
1845     );
1846
1847     ### dups FDs and stores them in a cache
1848     sub __dup_fds {
1849         my $self    = shift;
1850         my @fds     = @_;
1851
1852         __PACKAGE__->_debug( "# Closing the following fds: @fds" ) if $DEBUG;
1853
1854         for my $name ( @fds ) {
1855             my($redir, $fh, $glob) = @{$Map{$name}} or (
1856                 Carp::carp(loc("No such FD: '%1'", $name)), next );
1857
1858             ### MUST use the 2-arg version of open for dup'ing for
1859             ### 5.6.x compatibility. 5.8.x can use 3-arg open
1860             ### see perldoc5.6.2 -f open for details
1861             open $glob, $redir . fileno($fh) or (
1862                         Carp::carp(loc("Could not dup '$name': %1", $!)),
1863                         return
1864                     );
1865
1866             ### we should re-open this filehandle right now, not
1867             ### just dup it
1868             ### Use 2-arg version of open, as 5.5.x doesn't support
1869             ### 3-arg version =/
1870             if( $redir eq '>&' ) {
1871                 open( $fh, '>' . File::Spec->devnull ) or (
1872                     Carp::carp(loc("Could not reopen '$name': %1", $!)),
1873                     return
1874                 );
1875             }
1876         }
1877
1878         return 1;
1879     }
1880
1881     ### reopens FDs from the cache
1882     sub __reopen_fds {
1883         my $self    = shift;
1884         my @fds     = @_;
1885
1886         __PACKAGE__->_debug( "# Reopening the following fds: @fds" ) if $DEBUG;
1887
1888         for my $name ( @fds ) {
1889             my($redir, $fh, $glob) = @{$Map{$name}} or (
1890                 Carp::carp(loc("No such FD: '%1'", $name)), next );
1891
1892             ### MUST use the 2-arg version of open for dup'ing for
1893             ### 5.6.x compatibility. 5.8.x can use 3-arg open
1894             ### see perldoc5.6.2 -f open for details
1895             open( $fh, $redir . fileno($glob) ) or (
1896                     Carp::carp(loc("Could not restore '$name': %1", $!)),
1897                     return
1898                 );
1899
1900             ### close this FD, we're not using it anymore
1901             close $glob;
1902         }
1903         return 1;
1904
1905     }
1906 }
1907
1908 sub _debug {
1909     my $self    = shift;
1910     my $msg     = shift or return;
1911     my $level   = shift || 0;
1912
1913     local $Carp::CarpLevel += $level;
1914     Carp::carp($msg);
1915
1916     return 1;
1917 }
1918
1919 sub _pp_child_error {
1920     my $self    = shift;
1921     my $cmd     = shift or return;
1922     my $ce      = shift or return;
1923     my $pp_cmd  = ref $cmd ? "@$cmd" : $cmd;
1924
1925
1926     my $str;
1927     if( $ce == -1 ) {
1928         ### Include $! in the error message, so that the user can
1929         ### see 'No such file or directory' versus 'Permission denied'
1930         ### versus 'Cannot fork' or whatever the cause was.
1931         $str = "Failed to execute '$pp_cmd': $!";
1932
1933     } elsif ( $ce & 127 ) {
1934         ### some signal
1935         $str = loc( "'%1' died with signal %2, %3 coredump",
1936                $pp_cmd, ($ce & 127), ($ce & 128) ? 'with' : 'without');
1937
1938     } else {
1939         ### Otherwise, the command run but gave error status.
1940         $str = "'$pp_cmd' exited with value " . ($ce >> 8);
1941     }
1942
1943     $self->_debug( "# Child error '$ce' translated to: $str" ) if $DEBUG;
1944
1945     return $str;
1946 }
1947
1948 1;
1949
1950 __END__
1951
1952 =head2 $q = QUOTE
1953
1954 Returns the character used for quoting strings on this platform. This is
1955 usually a C<'> (single quote) on most systems, but some systems use different
1956 quotes. For example, C<Win32> uses C<"> (double quote).
1957
1958 You can use it as follows:
1959
1960   use IPC::Cmd qw[run QUOTE];
1961   my $cmd = q[echo ] . QUOTE . q[foo bar] . QUOTE;
1962
1963 This makes sure that C<foo bar> is treated as a string, rather than two
1964 separate arguments to the C<echo> function.
1965
1966 =head1 HOW IT WORKS
1967
1968 C<run> will try to execute your command using the following logic:
1969
1970 =over 4
1971
1972 =item *
1973
1974 If you have C<IPC::Run> installed, and the variable C<$IPC::Cmd::USE_IPC_RUN>
1975 is set to true (See the L<"Global Variables"> section) use that to execute
1976 the command. You will have the full output available in buffers, interactive commands
1977 are sure to work  and you are guaranteed to have your verbosity
1978 settings honored cleanly.
1979
1980 =item *
1981
1982 Otherwise, if the variable C<$IPC::Cmd::USE_IPC_OPEN3> is set to true
1983 (See the L<"Global Variables"> section), try to execute the command using
1984 L<IPC::Open3>. Buffers will be available on all platforms,
1985 interactive commands will still execute cleanly, and also your verbosity
1986 settings will be adhered to nicely;
1987
1988 =item *
1989
1990 Otherwise, if you have the C<verbose> argument set to true, we fall back
1991 to a simple C<system()> call. We cannot capture any buffers, but
1992 interactive commands will still work.
1993
1994 =item *
1995
1996 Otherwise we will try and temporarily redirect STDERR and STDOUT, do a
1997 C<system()> call with your command and then re-open STDERR and STDOUT.
1998 This is the method of last resort and will still allow you to execute
1999 your commands cleanly. However, no buffers will be available.
2000
2001 =back
2002
2003 =head1 Global Variables
2004
2005 The behaviour of IPC::Cmd can be altered by changing the following
2006 global variables:
2007
2008 =head2 $IPC::Cmd::VERBOSE
2009
2010 This controls whether IPC::Cmd will print any output from the
2011 commands to the screen or not. The default is 0.
2012
2013 =head2 $IPC::Cmd::USE_IPC_RUN
2014
2015 This variable controls whether IPC::Cmd will try to use L<IPC::Run>
2016 when available and suitable.
2017
2018 =head2 $IPC::Cmd::USE_IPC_OPEN3
2019
2020 This variable controls whether IPC::Cmd will try to use L<IPC::Open3>
2021 when available and suitable. Defaults to true.
2022
2023 =head2 $IPC::Cmd::WARN
2024
2025 This variable controls whether run-time warnings should be issued, like
2026 the failure to load an C<IPC::*> module you explicitly requested.
2027
2028 Defaults to true. Turn this off at your own risk.
2029
2030 =head2 $IPC::Cmd::INSTANCES
2031
2032 This variable controls whether C<can_run> will return all instances of
2033 the binary it finds in the C<PATH> when called in a list context.
2034
2035 Defaults to false, set to true to enable the described behaviour.
2036
2037 =head2 $IPC::Cmd::ALLOW_NULL_ARGS
2038
2039 This variable controls whether C<run> will remove any empty/null arguments
2040 it finds in command arguments.
2041
2042 Defaults to false, so it will remove null arguments. Set to true to allow
2043 them.
2044
2045 =head1 Caveats
2046
2047 =over 4
2048
2049 =item Whitespace and IPC::Open3 / system()
2050
2051 When using C<IPC::Open3> or C<system>, if you provide a string as the
2052 C<command> argument, it is assumed to be appropriately escaped. You can
2053 use the C<QUOTE> constant to use as a portable quote character (see above).
2054 However, if you provide an array reference, special rules apply:
2055
2056 If your command contains B<special characters> (< > | &), it will
2057 be internally stringified before executing the command, to avoid that these
2058 special characters are escaped and passed as arguments instead of retaining
2059 their special meaning.
2060
2061 However, if the command contained arguments that contained whitespace,
2062 stringifying the command would lose the significance of the whitespace.
2063 Therefore, C<IPC::Cmd> will quote any arguments containing whitespace in your
2064 command if the command is passed as an arrayref and contains special characters.
2065
2066 =item Whitespace and IPC::Run
2067
2068 When using C<IPC::Run>, if you provide a string as the C<command> argument,
2069 the string will be split on whitespace to determine the individual elements
2070 of your command. Although this will usually just Do What You Mean, it may
2071 break if you have files or commands with whitespace in them.
2072
2073 If you do not wish this to happen, you should provide an array
2074 reference, where all parts of your command are already separated out.
2075 Note however, if there are extra or spurious whitespaces in these parts,
2076 the parser or underlying code may not interpret it correctly, and
2077 cause an error.
2078
2079 Example:
2080 The following code
2081
2082     gzip -cdf foo.tar.gz | tar -xf -
2083
2084 should either be passed as
2085
2086     "gzip -cdf foo.tar.gz | tar -xf -"
2087
2088 or as
2089
2090     ['gzip', '-cdf', 'foo.tar.gz', '|', 'tar', '-xf', '-']
2091
2092 But take care not to pass it as, for example
2093
2094     ['gzip -cdf foo.tar.gz', '|', 'tar -xf -']
2095
2096 Since this will lead to issues as described above.
2097
2098
2099 =item IO Redirect
2100
2101 Currently it is too complicated to parse your command for IO
2102 redirections. For capturing STDOUT or STDERR there is a work around
2103 however, since you can just inspect your buffers for the contents.
2104
2105 =item Interleaving STDOUT/STDERR
2106
2107 Neither IPC::Run nor IPC::Open3 can interleave STDOUT and STDERR. For short
2108 bursts of output from a program, e.g. this sample,
2109
2110     for ( 1..4 ) {
2111         $_ % 2 ? print STDOUT $_ : print STDERR $_;
2112     }
2113
2114 IPC::[Run|Open3] will first read all of STDOUT, then all of STDERR, meaning
2115 the output looks like '13' on STDOUT and '24' on STDERR, instead of
2116
2117     1
2118     2
2119     3
2120     4
2121
2122 This has been recorded in L<rt.cpan.org> as bug #37532: Unable to interleave
2123 STDOUT and STDERR.
2124
2125 =back
2126
2127 =head1 See Also
2128
2129 L<IPC::Run>, L<IPC::Open3>
2130
2131 =head1 ACKNOWLEDGEMENTS
2132
2133 Thanks to James Mastros and Martijn van der Streek for their
2134 help in getting L<IPC::Open3> to behave nicely.
2135
2136 Thanks to Petya Kohts for the C<run_forked> code.
2137
2138 =head1 BUG REPORTS
2139
2140 Please report bugs or other issues to E<lt>bug-ipc-cmd@rt.cpan.orgE<gt>.
2141
2142 =head1 AUTHOR
2143
2144 Original author: Jos Boumans E<lt>kane@cpan.orgE<gt>.
2145 Current maintainer: Chris Williams E<lt>bingos@cpan.orgE<gt>.
2146
2147 =head1 COPYRIGHT
2148
2149 This library is free software; you may redistribute and/or modify it
2150 under the same terms as Perl itself.
2151
2152 =cut