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