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