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