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