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
CommitLineData
0d4ddeff
RGS
1package IPC::Cmd;
2
3use strict;
4
5BEGIN {
6
508236ce 7 use constant IS_VMS => $^O eq 'VMS' ? 1 : 0;
bdd3a62b
JB
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[< > | &];
508236ce 12 use constant QUOTE => do { IS_WIN32 ? q["] : q['] };
0d4ddeff
RGS
13
14 use Exporter ();
15 use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG
0c2c01a4 16 $USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN
eb96f3fa 17 $INSTANCES $ALLOW_NULL_ARGS
0d4ddeff
RGS
18 ];
19
6d1e0911 20 $VERSION = '0.84_01';
0d4ddeff
RGS
21 $VERBOSE = 0;
22 $DEBUG = 0;
23 $WARN = 1;
24 $USE_IPC_RUN = IS_WIN32 && !IS_WIN98;
25 $USE_IPC_OPEN3 = not IS_VMS;
eb96f3fa 26 $ALLOW_NULL_ARGS = 0;
0d4ddeff 27
0c2c01a4
CBW
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();
0c2c01a4 34 require FileHandle; FileHandle->import();
c7e51fe7 35 require Socket;
ccbe4e74 36 require Time::HiRes; Time::HiRes->import();
e667e1e1 37 require Win32 if IS_WIN32;
0c2c01a4
CBW
38 };
39 $CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32;
40
0d4ddeff 41 @ISA = qw[Exporter];
0c2c01a4 42 @EXPORT_OK = qw[can_run run run_forked QUOTE];
0d4ddeff
RGS
43}
44
45require Carp;
cce6d045 46use File::Spec;
0d4ddeff 47use Params::Check qw[check];
bdd3a62b 48use Text::ParseWords (); # import ONLY if needed!
0d4ddeff
RGS
49use Module::Load::Conditional qw[can_load];
50use Locale::Maketext::Simple Style => 'gettext';
51
52=pod
53
54=head1 NAME
55
56IPC::Cmd - finding and running system commands made easy
57
58=head1 SYNOPSIS
59
0c2c01a4 60 use IPC::Cmd qw[can_run run run_forked];
0d4ddeff
RGS
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,
bdd3a62b
JB
72 buffer => \$buffer,
73 timeout => 20 )
0d4ddeff
RGS
74 ) {
75 print "fetched webpage successfully: $buffer\n";
76 }
77
78
79 ### in list context ###
39b09a1b 80 my( $success, $error_message, $full_buf, $stdout_buf, $stderr_buf ) =
0d4ddeff
RGS
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
c7e51fe7
SH
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
0d4ddeff 95 ### check for features
508236ce
CBW
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;
0d4ddeff
RGS
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;
508236ce 103
0d4ddeff
RGS
104
105=head1 DESCRIPTION
106
39b09a1b
CBW
107IPC::Cmd allows you to run commands platform independently,
108interactively if desired, but have them still work.
0d4ddeff
RGS
109
110The C<can_run> function can tell you if a certain binary is installed
111and if so where, whereas the C<run> function can actually execute any
112of the commands you give it and give you a clear return value, as well
113as adhere to your verbosity settings.
114
508236ce 115=head1 CLASS METHODS
0d4ddeff 116
bdd3a62b 117=head2 $ipc_run_version = IPC::Cmd->can_use_ipc_run( [VERBOSE] )
0d4ddeff 118
508236ce 119Utility function that tells you if C<IPC::Run> is available.
39b09a1b
CBW
120If the C<verbose> flag is passed, it will print diagnostic messages
121if L<IPC::Run> can not be found or loaded.
0d4ddeff
RGS
122
123=cut
124
125
508236ce 126sub can_use_ipc_run {
0d4ddeff
RGS
127 my $self = shift;
128 my $verbose = shift || 0;
508236ce 129
39b09a1b 130 ### IPC::Run doesn't run on win98
0d4ddeff
RGS
131 return if IS_WIN98;
132
cd0a8b4c 133 ### if we don't have ipc::run, we obviously can't use it.
0d4ddeff 134 return unless can_load(
508236ce 135 modules => { 'IPC::Run' => '0.55' },
0d4ddeff
RGS
136 verbose => ($WARN && $verbose),
137 );
508236ce 138
0d4ddeff 139 ### otherwise, we're good to go
508236ce 140 return $IPC::Run::VERSION;
0d4ddeff
RGS
141}
142
bdd3a62b 143=head2 $ipc_open3_version = IPC::Cmd->can_use_ipc_open3( [VERBOSE] )
0d4ddeff 144
508236ce 145Utility function that tells you if C<IPC::Open3> is available.
0d4ddeff
RGS
146If the verbose flag is passed, it will print diagnostic messages
147if C<IPC::Open3> can not be found or loaded.
148
149=cut
150
151
508236ce 152sub can_use_ipc_open3 {
0d4ddeff
RGS
153 my $self = shift;
154 my $verbose = shift || 0;
155
39b09a1b 156 ### IPC::Open3 is not working on VMS because of a lack of fork.
bdd3a62b 157 return if IS_VMS;
abb5436b 158
cd0a8b4c 159 ### IPC::Open3 works on every non-VMS platform, but it can't
bdd3a62b 160 ### capture buffers on win32 :(
0d4ddeff
RGS
161 return unless can_load(
162 modules => { map {$_ => '0.0'} qw|IPC::Open3 IO::Select Symbol| },
163 verbose => ($WARN && $verbose),
164 );
508236ce 165
bdd3a62b 166 return $IPC::Open3::VERSION;
0d4ddeff
RGS
167}
168
169=head2 $bool = IPC::Cmd->can_capture_buffer
170
171Utility function that tells you if C<IPC::Cmd> is capable of
172capturing buffers in it's current configuration.
173
174=cut
175
176sub can_capture_buffer {
177 my $self = shift;
178
508236ce
CBW
179 return 1 if $USE_IPC_RUN && $self->can_use_ipc_run;
180 return 1 if $USE_IPC_OPEN3 && $self->can_use_ipc_open3;
0d4ddeff
RGS
181 return;
182}
183
0c2c01a4
CBW
184=head2 $bool = IPC::Cmd->can_use_run_forked
185
186Utility function that tells you if C<IPC::Cmd> is capable of
187providing C<run_forked> on the current platform.
0d4ddeff
RGS
188
189=head1 FUNCTIONS
190
191=head2 $path = can_run( PROGRAM );
192
39b09a1b 193C<can_run> takes only one argument: the name of a binary you wish
0d4ddeff
RGS
194to locate. C<can_run> works much like the unix binary C<which> or the bash
195command C<type>, which scans through your path, looking for the requested
22737eb3 196binary.
0d4ddeff
RGS
197
198Unlike C<which> and C<type>, this function is platform independent and
199will also work on, for example, Win32.
200
22737eb3
CBW
201If called in a scalar context it will return the full path to the binary
202you asked for if it was found, or C<undef> if it was not.
203
39b09a1b
CBW
204If called in a list context and the global variable C<$INSTANCES> is a true
205value, it will return a list of the full paths to instances
206of the binary where found in C<PATH>, or an empty list if it was not found.
0d4ddeff
RGS
207
208=cut
209
210sub 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
0d4ddeff
RGS
221 require File::Spec;
222 require ExtUtils::MakeMaker;
223
22737eb3
CBW
224 my @possibles;
225
0d4ddeff
RGS
226 if( File::Spec->file_name_is_absolute($command) ) {
227 return MM->maybe_command($command);
228
229 } else {
cce6d045 230 for my $dir (
265b802e 231 File::Spec->path,
cce6d045 232 File::Spec->curdir
e667e1e1
CBW
233 ) {
234 next if ! $dir || ! -d $dir;
235 my $abs = File::Spec->catfile( IS_WIN32 ? Win32::GetShortPathName( $dir ) : $dir, $command);
22737eb3 236 push @possibles, $abs if $abs = MM->maybe_command($abs);
0d4ddeff
RGS
237 }
238 }
22737eb3
CBW
239 return @possibles if wantarray and $INSTANCES;
240 return shift @possibles;
0d4ddeff
RGS
241}
242
bdd3a62b 243=head2 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR, timeout => DIGIT] );
0d4ddeff 244
bdd3a62b 245C<run> takes 4 arguments:
0d4ddeff
RGS
246
247=over 4
248
249=item command
250
251This is the command to execute. It may be either a string or an array
252reference.
253This is a required argument.
254
39b09a1b 255See L<"Caveats"> for remarks on how commands are parsed and their
0d4ddeff
RGS
256limitations.
257
258=item verbose
259
260This controls whether all output of a command should also be printed
261to STDOUT/STDERR or should only be trapped in buffers (NOTE: buffers
39b09a1b
CBW
262require L<IPC::Run> to be installed, or your system able to work with
263L<IPC::Open3>).
0d4ddeff
RGS
264
265It will default to the global setting of C<$IPC::Cmd::VERBOSE>,
266which by default is 0.
267
268=item buffer
269
270This will hold all the output of a command. It needs to be a reference
271to a scalar.
272Note that this will hold both the STDOUT and STDERR messages, and you
273have no way of telling which is which.
274If you require this distinction, run the C<run> command in list context
275and inspect the individual buffers.
276
277Of course, this requires that the underlying call supports buffers. See
39b09a1b 278the note on buffers above.
0d4ddeff 279
bdd3a62b
JB
280=item timeout
281
282Sets the maximum time the command is allowed to run before aborting,
283using the built-in C<alarm()> call. If the timeout is triggered, the
508236ce 284C<errorcode> in the return value will be set to an object of the
39b09a1b 285C<IPC::Cmd::TimeOut> class. See the L<"error message"> section below for
bdd3a62b
JB
286details.
287
288Defaults to C<0>, meaning no timeout is set.
289
0d4ddeff
RGS
290=back
291
292C<run> will return a simple C<true> or C<false> when called in scalar
293context.
294In list context, you will be returned a list of the following items:
295
296=over 4
297
298=item success
299
300A simple boolean indicating if the command executed without errors or
301not.
302
bdd3a62b 303=item error message
0d4ddeff 304
39b09a1b 305If the first element of the return value (C<success>) was 0, then some
bdd3a62b 306error occurred. This second element is the error message the command
508236ce
CBW
307you requested exited with, if available. This is generally a pretty
308printed value of C<$?> or C<$@>. See C<perldoc perlvar> for details on
bdd3a62b
JB
309what they can contain.
310If the error was a timeout, the C<error message> will be prefixed with
311the string C<IPC::Cmd::TimeOut>, the timeout class.
0d4ddeff
RGS
312
313=item full_buffer
314
39b09a1b 315This is an array reference containing all the output the command
0d4ddeff 316generated.
39b09a1b
CBW
317Note that buffers are only available if you have L<IPC::Run> installed,
318or if your system is able to work with L<IPC::Open3> -- see below).
319Otherwise, this element will be C<undef>.
0d4ddeff
RGS
320
321=item out_buffer
322
39b09a1b
CBW
323This is an array reference containing all the output sent to STDOUT the
324command generated. The notes from L<"full_buffer"> apply.
0d4ddeff
RGS
325
326=item error_buffer
327
328This is an arrayreference containing all the output sent to STDERR the
39b09a1b
CBW
329command generated. The notes from L<"full_buffer"> apply.
330
0d4ddeff
RGS
331
332=back
333
39b09a1b 334See the L<"HOW IT WORKS"> section below to see how C<IPC::Cmd> decides
0d4ddeff
RGS
335what modules or function calls to use when issuing a command.
336
337=cut
338
bdd3a62b 339{ my @acc = qw[ok error _fds];
508236ce 340
bdd3a62b
JB
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
0c2c01a4
CBW
351sub can_use_run_forked {
352 return $CAN_USE_RUN_FORKED eq "1";
353}
354
e667e1e1
CBW
355# incompatible with POSIX::SigAction
356#
357sub 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) = @_;
508236ce 371
ccf86ece 372 # $s is a closure referring to real signal name
e667e1e1
CBW
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
ccf86ece 386 # calls some other signal handler which
e667e1e1
CBW
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
0c2c01a4
CBW
402# give process a chance sending TERM,
403# waiting for a while (2 seconds)
404# and killing it with KILL
405sub kill_gently {
e667e1e1 406 my ($pid, $opts) = @_;
508236ce 407
eb96f3fa
CBW
408 require POSIX;
409
e667e1e1
CBW
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'};
508236ce 414
e667e1e1
CBW
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 }
508236ce 421
0c2c01a4 422 my $child_finished = 0;
e667e1e1 423 my $wait_start_time = time();
0c2c01a4 424
e667e1e1 425 while (!$child_finished && $wait_start_time + $opts->{'wait_time'} > time()) {
eb96f3fa 426 my $waitpid = waitpid($pid, POSIX::WNOHANG);
0c2c01a4
CBW
427 if ($waitpid eq -1) {
428 $child_finished = 1;
429 }
e667e1e1 430 Time::HiRes::usleep(250000); # quarter of a second
0c2c01a4 431 }
4d239afe
RGS
432
433 if (!$child_finished) {
e667e1e1
CBW
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 }
4d239afe 440 }
0c2c01a4
CBW
441}
442
443sub open3_run {
444 my ($cmd, $opts) = @_;
445
446 $opts = {} unless $opts;
508236ce 447
0c2c01a4
CBW
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 #
f7f926be 475 local $SIG{'PIPE'} = sub { 1; };
508236ce 476
0c2c01a4
CBW
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") {
f7f926be
CBW
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
64883bec 537 POSIX::_exit 1;
0c2c01a4
CBW
538 }
539
540 if ($got_sig_child) {
e667e1e1
CBW
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);
0c2c01a4
CBW
551 $child_finished = 1;
552 }
553 }
554
ccbe4e74 555 Time::HiRes::usleep(1);
0c2c01a4
CBW
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
f7f926be
CBW
583 my $waitpid_ret = waitpid($pid, 0);
584 my $real_exit = $?;
585 my $exit_value = $real_exit >> 8;
0c2c01a4 586
e667e1e1
CBW
587 # since we've successfully reaped the child,
588 # let our parent know about this.
589 #
0c2c01a4
CBW
590 if ($opts->{'parent_info'}) {
591 my $ps = $opts->{'parent_info'};
f7f926be
CBW
592
593 # child was killed, inform parent
594 if ($real_exit & 127) {
595 print $ps "$pid killed with " . ($real_exit & 127) . "\n";
596 }
597
0c2c01a4
CBW
598 print $ps "reaped $pid\n";
599 }
600
0c2c01a4
CBW
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
4d239afe 613=head2 $hashref = run_forked( COMMAND, { child_stdin => SCALAR, timeout => DIGIT, stdout_handler => CODEREF, stderr_handler => CODEREF} );
635ccb1c 614
4d239afe 615C<run_forked> is used to execute some program or a coderef,
635ccb1c 616optionally feed it with some input, get its return code
2108160e 617and output (both stdout and stderr into separate buffers).
39b09a1b
CBW
618In addition, it allows to terminate the program
619if it takes too long to finish.
635ccb1c
CBW
620
621The important and distinguishing feature of run_forked
622is execution timeout which at first seems to be
623quite a simple task but if you think
624that the program which you're spawning
625might spawn some children itself (which
626in their turn could do the same and so on)
627it turns out to be not a simple issue.
628
629C<run_forked> is designed to survive and
630successfully terminate almost any long running task,
631even a fork bomb in case your system has the resources
632to survive during given timeout.
633
634This is achieved by creating separate watchdog process
635which spawns the specified program in a separate
636process session and supervises it: optionally
637feeds it with input, stores its exit code,
638stdout and stderr, terminates it in case
639it runs longer than specified.
640
4d239afe 641Invocation requires the command to be executed or a coderef and optionally a hashref of options:
635ccb1c
CBW
642
643=over
644
645=item C<timeout>
646
cd0a8b4c 647Specify in seconds how long to run the command before it is killed with SIG_KILL (9),
635ccb1c
CBW
648which effectively terminates it and all of its children (direct or indirect).
649
650=item C<child_stdin>
651
39b09a1b 652Specify some text that will be passed into the C<STDIN> of the executed program.
635ccb1c
CBW
653
654=item C<stdout_handler>
655
508236ce 656Coderef of a subroutine to call when a portion of data is received on
39b09a1b 657STDOUT from the executing program.
635ccb1c
CBW
658
659=item C<stderr_handler>
660
508236ce 661Coderef of a subroutine to call when a portion of data is received on
39b09a1b
CBW
662STDERR from the executing program.
663
635ccb1c 664
4d239afe
RGS
665=item C<discard_output>
666
508236ce
CBW
667Discards the buffering of the standard output and standard errors for return by run_forked().
668With this option you have to use the std*_handlers to read what the command outputs.
4d239afe
RGS
669Useful for commands that send a lot of output.
670
671=item C<terminate_on_parent_sudden_death>
672
673Enable this option if you wish all spawned processes to be killed if the initially spawned
674process (the parent) is killed or dies without waiting for child processes.
675
635ccb1c
CBW
676=back
677
678C<run_forked> will return a HASHREF with the following keys:
679
680=over
681
682=item C<exit_code>
683
684The exit code of the executed program.
685
686=item C<timeout>
687
688The number of seconds the program ran for before being terminated, or 0 if no timeout occurred.
689
690=item C<stdout>
691
508236ce 692Holds the standard output of the executed command (or empty string if
39b09a1b 693there was no STDOUT output or if C<discard_output> was used; it's always defined!)
635ccb1c
CBW
694
695=item C<stderr>
696
508236ce 697Holds the standard error of the executed command (or empty string if
39b09a1b 698there was no STDERR output or if C<discard_output> was used; it's always defined!)
635ccb1c
CBW
699
700=item C<merged>
701
702Holds the standard output and error of the executed command merged into one stream
39b09a1b 703(or empty string if there was no output at all or if C<discard_output> was used; it's always defined!)
635ccb1c
CBW
704
705=item C<err_msg>
706
707Holds some explanation in the case of an error.
708
709=back
0c2c01a4
CBW
710
711=cut
712
713sub 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 }
0c2c01a4 721
c7e51fe7
SH
722 require POSIX;
723
0c2c01a4 724 my ($cmd, $opts) = @_;
c7e51fe7
SH
725 if (ref($cmd) eq 'ARRAY') {
726 $cmd = join(" ", @{$cmd});
727 }
0c2c01a4
CBW
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'};
e667e1e1 736 $opts->{'terminate_wait_time'} = 2 unless defined($opts->{'terminate_wait_time'});
0c2c01a4 737
f7f926be
CBW
738 # turned on by default
739 $opts->{'clean_up_children'} = 1 unless defined($opts->{'clean_up_children'});
740
0c2c01a4
CBW
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;
508236ce 748
0c2c01a4
CBW
749 # sockets for child -> parent internal communication
750 my $child_info_socket;
751 my $parent_info_socket;
752
c7e51fe7 753 socketpair($child_stdout_socket, $parent_stdout_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
0c2c01a4 754 die ("socketpair: $!");
c7e51fe7 755 socketpair($child_stderr_socket, $parent_stderr_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
0c2c01a4 756 die ("socketpair: $!");
c7e51fe7 757 socketpair($child_info_socket, $parent_info_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
0c2c01a4
CBW
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
0c2c01a4
CBW
777 my $flags;
778
779 # prepare sockets to read from child
780
781 $flags = 0;
eb96f3fa
CBW
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: $!";
0c2c01a4
CBW
785
786 $flags = 0;
eb96f3fa
CBW
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: $!";
0c2c01a4
CBW
790
791 $flags = 0;
eb96f3fa
CBW
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: $!";
0c2c01a4
CBW
795
796 # print "child $pid started\n";
797
c7e51fe7
SH
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
4d239afe 822 my $child_timedout = 0;
0c2c01a4 823 my $child_finished = 0;
635ccb1c
CBW
824 my $child_stdout = '';
825 my $child_stderr = '';
826 my $child_merged = '';
0c2c01a4 827 my $child_exit_code = 0;
f7f926be 828 my $child_killed_by_signal = 0;
4d239afe 829 my $parent_died = 0;
0c2c01a4
CBW
830
831 my $got_sig_child = 0;
e667e1e1 832 my $got_sig_quit = 0;
f7f926be
CBW
833 my $orig_sig_child = $SIG{'CHLD'};
834
0c2c01a4
CBW
835 $SIG{'CHLD'} = sub { $got_sig_child = time(); };
836
e667e1e1
CBW
837 if ($opts->{'terminate_on_signal'}) {
838 install_layered_signal($opts->{'terminate_on_signal'}, sub { $got_sig_quit = time(); });
839 }
840
0c2c01a4
CBW
841 my $child_child_pid;
842
843 while (!$child_finished) {
4d239afe
RGS
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") {
f7f926be
CBW
853 kill_gently ($pid, {
854 'first_kill_type' => 'process_group',
855 'final_kill_type' => 'process_group',
856 'wait_time' => $opts->{'terminate_wait_time'}
857 });
4d239afe
RGS
858 $parent_died = 1;
859 }
860
861 $opts->{'runtime'}->{'last_parent_check'} = $now;
862 }
863 }
864
0c2c01a4
CBW
865 # user specified timeout
866 if ($opts->{'timeout'}) {
4d239afe 867 if ($now - $start_time > $opts->{'timeout'}) {
f7f926be
CBW
868 kill_gently ($pid, {
869 'first_kill_type' => 'process_group',
870 'final_kill_type' => 'process_group',
871 'wait_time' => $opts->{'terminate_wait_time'}
872 });
0c2c01a4
CBW
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) {
4d239afe 881 if ($now - $got_sig_child > 10) {
0c2c01a4
CBW
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
e667e1e1
CBW
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
eb96f3fa 897 my $waitpid = waitpid($pid, POSIX::WNOHANG);
0c2c01a4
CBW
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
c7e51fe7
SH
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 }
0c2c01a4 926 }
c7e51fe7
SH
927 elsif ($count eq 0) {
928 $select->remove($fd);
929 $fd->close();
930 if ($str->{'scalar_buffer'}) {
931 $data = $str->{'scalar_buffer'} . "\n";
932 }
0c2c01a4 933 }
c7e51fe7
SH
934 else {
935 die("error during sysread on [$fd]: " . $!);
f7f926be 936 }
0c2c01a4 937
c7e51fe7
SH
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 }
0c2c01a4 954
c7e51fe7
SH
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 }
0c2c01a4 960 }
c7e51fe7
SH
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 }
4d239afe 970 }
c7e51fe7
SH
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 }
0c2c01a4
CBW
980 }
981 }
982
ccbe4e74 983 Time::HiRes::usleep(1);
0c2c01a4
CBW
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,
ccf86ece 996 # killing it brutally.
0c2c01a4
CBW
997 #
998 if ($child_child_pid) {
999 kill_gently($child_child_pid);
1000 }
1001
e667e1e1
CBW
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
0c2c01a4
CBW
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,
635ccb1c 1028 'merged' => $child_merged,
0c2c01a4
CBW
1029 'timeout' => $child_timedout ? $opts->{'timeout'} : 0,
1030 'exit_code' => $child_exit_code,
e667e1e1 1031 'parent_died' => $parent_died,
f7f926be 1032 'killed_by_signal' => $child_killed_by_signal,
e667e1e1 1033 'child_pgid' => $pid,
c7e51fe7 1034 'cmd' => $cmd,
0c2c01a4
CBW
1035 };
1036
635ccb1c 1037 my $err_msg = '';
0c2c01a4
CBW
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 }
4d239afe
RGS
1044 if ($o->{'parent_died'}) {
1045 $err_msg .= "parent died\n";
1046 }
0c2c01a4
CBW
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 }
f7f926be
CBW
1053 if ($o->{'killed_by_signal'}) {
1054 $err_msg .= "killed by signal [" . $o->{'killed_by_signal'} . "]\n";
1055 }
0c2c01a4
CBW
1056 $o->{'err_msg'} = $err_msg;
1057
f7f926be
CBW
1058 if ($orig_sig_child) {
1059 $SIG{'CHLD'} = $orig_sig_child;
1060 }
1061 else {
1062 delete($SIG{'CHLD'});
1063 }
1064
0c2c01a4
CBW
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
f7f926be
CBW
1078 if ($opts->{'child_BEGIN'} && ref($opts->{'child_BEGIN'}) eq 'CODE') {
1079 $opts->{'child_BEGIN'}->();
1080 }
1081
0c2c01a4
CBW
1082 close($child_stdout_socket);
1083 close($child_stderr_socket);
1084 close($child_info_socket);
1085
4d239afe
RGS
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') {
c7e51fe7
SH
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
4d239afe
RGS
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 }
0c2c01a4
CBW
1116
1117 close($parent_stdout_socket);
1118 close($parent_stderr_socket);
1119 close($parent_info_socket);
1120
f7f926be
CBW
1121 if ($opts->{'child_END'} && ref($opts->{'child_END'}) eq 'CODE') {
1122 $opts->{'child_END'}->();
1123 }
1124
c7e51fe7 1125 $| = 1;
64883bec 1126 POSIX::_exit $child_exit_code;
0c2c01a4
CBW
1127 }
1128}
1129
0d4ddeff 1130sub run {
bdd3a62b
JB
1131 ### container to store things in
1132 my $self = bless {}, __PACKAGE__;
1133
0d4ddeff 1134 my %hash = @_;
508236ce 1135
0d4ddeff
RGS
1136 ### if the user didn't provide a buffer, we'll store it here.
1137 my $def_buf = '';
508236ce 1138
bdd3a62b 1139 my($verbose,$cmd,$buffer,$timeout);
0d4ddeff
RGS
1140 my $tmpl = {
1141 verbose => { default => $VERBOSE, store => \$verbose },
1142 buffer => { default => \$def_buf, store => \$buffer },
1143 command => { required => 1, store => \$cmd,
508236ce 1144 allow => sub { !ref($_[0]) or ref($_[0]) eq 'ARRAY' },
0d4ddeff 1145 },
508236ce 1146 timeout => { default => 0, store => \$timeout },
0d4ddeff 1147 };
508236ce 1148
0d4ddeff 1149 unless( check( $tmpl, \%hash, $VERBOSE ) ) {
bdd3a62b
JB
1150 Carp::carp( loc( "Could not validate input: %1",
1151 Params::Check->last_error ) );
0d4ddeff 1152 return;
508236ce 1153 };
0d4ddeff 1154
0ec35138
JB
1155 $cmd = _quote_args_vms( $cmd ) if IS_VMS;
1156
bdd3a62b 1157 ### strip any empty elements from $cmd if present
eb96f3fa
CBW
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 }
bdd3a62b
JB
1164
1165 my $pp_cmd = (ref $cmd ? "@$cmd" : $cmd);
1166 print loc("Running [%1]...\n", $pp_cmd ) if $verbose;
0d4ddeff
RGS
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;
508236ce 1173
0d4ddeff
RGS
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;
508236ce 1181
0d4ddeff
RGS
1182 print STDOUT $buf if $verbose;
1183 push @buffer, $buf;
1184 push @buff_out, $buf;
1185 };
508236ce 1186
0d4ddeff
RGS
1187 ### capture STDERR
1188 my $_err_handler = sub {
1189 my $buf = shift;
1190 return unless defined $buf;
508236ce 1191
0d4ddeff
RGS
1192 print STDERR $buf if $verbose;
1193 push @buffer, $buf;
1194 push @buff_err, $buf;
1195 };
508236ce 1196
0d4ddeff
RGS
1197
1198 ### flag to indicate we have a buffer captured
bdd3a62b 1199 my $have_buffer = $self->can_capture_buffer ? 1 : 0;
508236ce 1200
0d4ddeff
RGS
1201 ### flag indicating if the subcall went ok
1202 my $ok;
508236ce 1203
cd0a8b4c 1204 ### don't look at previous errors:
508236ce 1205 local $?;
bdd3a62b
JB
1206 local $@;
1207 local $!;
1208
1209 ### we might be having a timeout set
508236ce
CBW
1210 eval {
1211 local $SIG{ALRM} = sub { die bless sub {
1212 ALARM_CLASS .
bdd3a62b
JB
1213 qq[: Command '$pp_cmd' aborted by alarm after $timeout seconds]
1214 }, ALARM_CLASS } if $timeout;
1215 alarm $timeout || 0;
508236ce 1216
bdd3a62b 1217 ### IPC::Run is first choice if $USE_IPC_RUN is set.
508236ce 1218 if( !IS_WIN32 and $USE_IPC_RUN and $self->can_use_ipc_run( 1 ) ) {
bdd3a62b 1219 ### ipc::run handlers needs the command as a string or an array ref
508236ce 1220
bdd3a62b
JB
1221 $self->_debug( "# Using IPC::Run. Have buffer: $have_buffer" )
1222 if $DEBUG;
508236ce 1223
bdd3a62b 1224 $ok = $self->_ipc_run( $cmd, $_out_handler, $_err_handler );
508236ce 1225
bdd3a62b
JB
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 ) ) {
508236ce 1229
bdd3a62b
JB
1230 $self->_debug("# Using IPC::Open3. Have buffer: $have_buffer")
1231 if $DEBUG;
508236ce 1232
bdd3a62b 1233 ### in case there are pipes in there;
508236ce
CBW
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
bdd3a62b 1240 );
508236ce 1241
bdd3a62b
JB
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 }
508236ce 1248
bdd3a62b
JB
1249 alarm 0;
1250 };
508236ce 1251
bdd3a62b 1252 ### restore STDIN after duping, or STDIN will be closed for
508236ce 1253 ### this current perl process!
bdd3a62b 1254 $self->__reopen_fds( @{ $self->_fds} ) if $self->_fds;
508236ce 1255
bdd3a62b
JB
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 }
0d4ddeff 1266 }
508236ce 1267
0d4ddeff
RGS
1268 ### fill the buffer;
1269 $$buffer = join '', @buffer if @buffer;
508236ce 1270
0d4ddeff
RGS
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
bdd3a62b
JB
1275 ? ($ok, $err, \@buffer, \@buff_out, \@buff_err)
1276 : ($ok, $err )
0d4ddeff 1277 : $ok
508236ce
CBW
1278
1279
0d4ddeff
RGS
1280}
1281
508236ce
CBW
1282sub _open3_run_win32 {
1283 my $self = shift;
1284 my $cmd = shift;
1285 my $outhand = shift;
1286 my $errhand = shift;
1287
c7e51fe7
SH
1288 require Socket;
1289
508236ce 1290 my $pipe = sub {
c7e51fe7 1291 socketpair($_[0], $_[1], &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC)
508236ce
CBW
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 {
c7e51fe7
SH
1341 $obj->( "$buf" );
1342 }
508236ce
CBW
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
1361sub _open3_run {
0d4ddeff
RGS
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.
508236ce 1375 use Symbol;
0d4ddeff
RGS
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.
508236ce
CBW
1385 my @fds_to_dup = ( IS_WIN32 && !$verbose
1386 ? qw[STDIN STDOUT STDERR]
0d4ddeff
RGS
1387 : qw[STDIN]
1388 );
bdd3a62b
JB
1389 $self->_fds( \@fds_to_dup );
1390 $self->__dup_fds( @fds_to_dup );
508236ce 1391
bdd3a62b
JB
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 );
508236ce 1395
cd0a8b4c 1396 ### don't stringify @$cmd, so spaces in filenames/paths are
bdd3a62b 1397 ### treated properly
508236ce 1398 my $pid = eval {
bdd3a62b 1399 IPC::Open3::open3(
0d4ddeff
RGS
1400 '<&STDIN',
1401 (IS_WIN32 ? '>&STDOUT' : $kidout),
1402 (IS_WIN32 ? '>&STDERR' : $kiderror),
bdd3a62b 1403 ( ref $cmd ? @$cmd : $cmd ),
0d4ddeff 1404 );
bdd3a62b 1405 };
508236ce
CBW
1406
1407 ### open3 error occurred
bdd3a62b
JB
1408 if( $@ and $@ =~ /^open3:/ ) {
1409 $self->ok( 0 );
1410 $self->error( $@ );
1411 return;
1412 };
0d4ddeff
RGS
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(
508236ce
CBW
1418 (IS_WIN32 ? \*STDERR : $kiderror),
1419 \*STDIN,
1420 (IS_WIN32 ? \*STDOUT : $kidout)
1421 );
0d4ddeff
RGS
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
ccf86ece 1427 ### add an explicit break statement
0d4ddeff 1428 ### code courtesy of theorbtwo from #london.pm
cce6d045
JB
1429 my $stdout_done = 0;
1430 my $stderr_done = 0;
0d4ddeff
RGS
1431 OUTER: while ( my @ready = $selector->can_read ) {
1432
1433 for my $h ( @ready ) {
1434 my $buf;
508236ce 1435
0d4ddeff
RGS
1436 ### $len is the amount of bytes read
1437 my $len = sysread( $h, $buf, 4096 ); # try to read 4096 bytes
508236ce 1438
0d4ddeff
RGS
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 }
bdd3a62b 1445
0d4ddeff
RGS
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;
cce6d045
JB
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);
0d4ddeff
RGS
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!
bdd3a62b
JB
1464 ### done in the parent call now
1465 # $self->__reopen_fds( @fds_to_dup );
508236ce 1466
bdd3a62b
JB
1467 ### some error occurred
1468 if( $? ) {
508236ce 1469 $self->error( $self->_pp_child_error( $cmd, $? ) );
bdd3a62b
JB
1470 $self->ok( 0 );
1471 return;
1472 } else {
1473 return $self->ok( 1 );
1474 }
0d4ddeff
RGS
1475}
1476
39b09a1b 1477### Text::ParseWords::shellwords() uses unix semantics. that will break
bdd3a62b 1478### on win32
508236ce 1479{ my $parse_sub = IS_WIN32
bdd3a62b
JB
1480 ? __PACKAGE__->can('_split_like_shell_win32')
1481 : Text::ParseWords->can('shellwords');
1482
508236ce 1483 sub _ipc_run {
bdd3a62b
JB
1484 my $self = shift;
1485 my $cmd = shift;
1486 my $_out_handler = shift;
1487 my $_err_handler = shift;
508236ce 1488
bdd3a62b
JB
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 # ]
0d4ddeff 1507
508236ce
CBW
1508
1509 my @command;
bdd3a62b 1510 my $special_chars;
508236ce 1511
bdd3a62b
JB
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
508236ce 1535 ### if there's a pipe in the command, *STDIN needs to
bdd3a62b
JB
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
cd0a8b4c 1542 ### don't pass STDIN at all.
bdd3a62b
JB
1543 # if( $special_chars and $special_chars =~ /\|/ ) {
1544 # ### only add STDIN the first time..
1545 # my $i;
508236ce
CBW
1546 # @command = map { ($_ eq '|' && not $i++)
1547 # ? ( \*STDIN, $_ )
1548 # : $_
1549 # } @command;
bdd3a62b
JB
1550 # } else {
1551 # push @command, \*STDIN;
1552 # }
508236ce 1553
bdd3a62b 1554 # \*STDIN is already included in the @command, see a few lines up
508236ce 1555 my $ok = eval { IPC::Run::run( @command,
bdd3a62b
JB
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
508236ce
CBW
1572 ### unless it's an alarm
1573 if( $@ and not UNIVERSAL::isa( $@, ALARM_CLASS ) ) {
bdd3a62b
JB
1574 $self->error( $@ );
1575
508236ce 1576 ### if it *is* an alarm, propagate
bdd3a62b
JB
1577 } elsif( $@ ) {
1578 die $@;
1579
1580 ### some error in the sub command
0d4ddeff 1581 } else {
bdd3a62b 1582 $self->error( $self->_pp_child_error( $cmd, $? ) );
0d4ddeff 1583 }
508236ce 1584
bdd3a62b 1585 return;
0d4ddeff 1586 }
0d4ddeff 1587 }
0d4ddeff
RGS
1588}
1589
508236ce 1590sub _system_run {
0d4ddeff
RGS
1591 my $self = shift;
1592 my $cmd = shift;
1593 my $verbose = shift || 0;
1594
bdd3a62b
JB
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
0d4ddeff 1599 my @fds_to_dup = $verbose ? () : qw[STDOUT STDERR];
bdd3a62b
JB
1600 $self->_fds( \@fds_to_dup );
1601 $self->__dup_fds( @fds_to_dup );
1602
0d4ddeff 1603 ### system returns 'true' on failure -- the exit code of the cmd
bdd3a62b
JB
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 ) {
508236ce 1626
bdd3a62b
JB
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;
508236ce 1631
bdd3a62b
JB
1632 $self->_debug( "# Quoted $fixed arguments containing whitespace" )
1633 if $DEBUG && $fixed;
508236ce 1634
bdd3a62b
JB
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
0ec35138
JB
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
1648sub _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
bdd3a62b
JB
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
1683sub _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.
508236ce 1691
bdd3a62b 1692 local $_ = shift;
508236ce 1693
bdd3a62b
JB
1694 my @argv;
1695 return @argv unless defined() && length();
508236ce 1696
bdd3a62b
JB
1697 my $arg = '';
1698 my( $i, $quote_mode ) = ( 0, 0 );
508236ce 1699
bdd3a62b 1700 while ( $i < length() ) {
508236ce 1701
bdd3a62b
JB
1702 my $ch = substr( $_, $i , 1 );
1703 my $next_ch = substr( $_, $i+1, 1 );
508236ce 1704
bdd3a62b
JB
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 ) {
39b09a1b 1725 push( @argv, $arg ) if defined( $arg ) && length( $arg );
bdd3a62b
JB
1726 $arg = '';
1727 ++$i while substr( $_, $i + 1, 1 ) eq ' ';
1728 } else {
1729 $arg .= $ch;
1730 }
508236ce 1731
bdd3a62b
JB
1732 $i++;
1733 }
508236ce 1734
bdd3a62b
JB
1735 push( @argv, $arg ) if defined( $arg ) && length( $arg );
1736 return @argv;
0d4ddeff
RGS
1737}
1738
bdd3a62b
JB
1739
1740
0d4ddeff
RGS
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 );
508236ce
CBW
1760
1761 ### MUST use the 2-arg version of open for dup'ing for
ccf86ece 1762 ### 5.6.x compatibility. 5.8.x can use 3-arg open
508236ce 1763 ### see perldoc5.6.2 -f open for details
0d4ddeff
RGS
1764 open $glob, $redir . fileno($fh) or (
1765 Carp::carp(loc("Could not dup '$name': %1", $!)),
1766 return
508236ce
CBW
1767 );
1768
0d4ddeff
RGS
1769 ### we should re-open this filehandle right now, not
1770 ### just dup it
7edb818e
JB
1771 ### Use 2-arg version of open, as 5.5.x doesn't support
1772 ### 3-arg version =/
0d4ddeff 1773 if( $redir eq '>&' ) {
7edb818e 1774 open( $fh, '>' . File::Spec->devnull ) or (
0d4ddeff
RGS
1775 Carp::carp(loc("Could not reopen '$name': %1", $!)),
1776 return
1777 );
1778 }
1779 }
508236ce 1780
0d4ddeff
RGS
1781 return 1;
1782 }
1783
508236ce 1784 ### reopens FDs from the cache
0d4ddeff
RGS
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
508236ce 1795 ### MUST use the 2-arg version of open for dup'ing for
ccf86ece 1796 ### 5.6.x compatibility. 5.8.x can use 3-arg open
0d4ddeff
RGS
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
508236ce
CBW
1801 );
1802
0d4ddeff 1803 ### close this FD, we're not using it anymore
508236ce
CBW
1804 close $glob;
1805 }
1806 return 1;
1807
0d4ddeff 1808 }
508236ce 1809}
0d4ddeff
RGS
1810
1811sub _debug {
1812 my $self = shift;
1813 my $msg = shift or return;
1814 my $level = shift || 0;
508236ce 1815
0d4ddeff
RGS
1816 local $Carp::CarpLevel += $level;
1817 Carp::carp($msg);
508236ce 1818
0d4ddeff
RGS
1819 return 1;
1820}
1821
bdd3a62b
JB
1822sub _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;
508236ce
CBW
1827
1828
bdd3a62b
JB
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
508236ce 1836 } elsif ( $ce & 127 ) {
bdd3a62b
JB
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 }
508236ce 1845
bdd3a62b 1846 $self->_debug( "# Child error '$ce' translated to: $str" ) if $DEBUG;
508236ce 1847
bdd3a62b
JB
1848 return $str;
1849}
0d4ddeff
RGS
1850
18511;
1852
bdd3a62b
JB
1853=head2 $q = QUOTE
1854
1855Returns the character used for quoting strings on this platform. This is
1856usually a C<'> (single quote) on most systems, but some systems use different
508236ce 1857quotes. For example, C<Win32> uses C<"> (double quote).
bdd3a62b
JB
1858
1859You can use it as follows:
1860
1861 use IPC::Cmd qw[run QUOTE];
1862 my $cmd = q[echo ] . QUOTE . q[foo bar] . QUOTE;
1863
1864This makes sure that C<foo bar> is treated as a string, rather than two
2108160e 1865separate arguments to the C<echo> function.
0d4ddeff
RGS
1866
1867__END__
1868
1869=head1 HOW IT WORKS
1870
1871C<run> will try to execute your command using the following logic:
1872
1873=over 4
1874
1875=item *
1876
1877If you have C<IPC::Run> installed, and the variable C<$IPC::Cmd::USE_IPC_RUN>
508236ce
CBW
1878is set to true (See the L<"Global Variables"> section) use that to execute
1879the command. You will have the full output available in buffers, interactive commands
1880are sure to work and you are guaranteed to have your verbosity
0d4ddeff
RGS
1881settings honored cleanly.
1882
1883=item *
1884
508236ce 1885Otherwise, if the variable C<$IPC::Cmd::USE_IPC_OPEN3> is set to true
39b09a1b 1886(See the L<"Global Variables"> section), try to execute the command using
508236ce 1887L<IPC::Open3>. Buffers will be available on all platforms,
cce6d045 1888interactive commands will still execute cleanly, and also your verbosity
0d4ddeff
RGS
1889settings will be adhered to nicely;
1890
1891=item *
1892
39b09a1b
CBW
1893Otherwise, if you have the C<verbose> argument set to true, we fall back
1894to a simple C<system()> call. We cannot capture any buffers, but
0d4ddeff
RGS
1895interactive commands will still work.
1896
1897=item *
1898
1899Otherwise we will try and temporarily redirect STDERR and STDOUT, do a
39b09a1b 1900C<system()> call with your command and then re-open STDERR and STDOUT.
0d4ddeff
RGS
1901This is the method of last resort and will still allow you to execute
1902your commands cleanly. However, no buffers will be available.
1903
1904=back
1905
1906=head1 Global Variables
1907
1908The behaviour of IPC::Cmd can be altered by changing the following
1909global variables:
1910
1911=head2 $IPC::Cmd::VERBOSE
1912
1913This controls whether IPC::Cmd will print any output from the
39b09a1b 1914commands to the screen or not. The default is 0.
0d4ddeff
RGS
1915
1916=head2 $IPC::Cmd::USE_IPC_RUN
1917
1918This variable controls whether IPC::Cmd will try to use L<IPC::Run>
508236ce 1919when available and suitable.
0d4ddeff
RGS
1920
1921=head2 $IPC::Cmd::USE_IPC_OPEN3
1922
1923This variable controls whether IPC::Cmd will try to use L<IPC::Open3>
1924when available and suitable. Defaults to true.
1925
1926=head2 $IPC::Cmd::WARN
1927
39b09a1b 1928This variable controls whether run-time warnings should be issued, like
0d4ddeff
RGS
1929the failure to load an C<IPC::*> module you explicitly requested.
1930
1931Defaults to true. Turn this off at your own risk.
1932
22737eb3
CBW
1933=head2 $IPC::Cmd::INSTANCES
1934
1935This variable controls whether C<can_run> will return all instances of
1936the binary it finds in the C<PATH> when called in a list context.
1937
1938Defaults to false, set to true to enable the described behaviour.
1939
eb96f3fa
CBW
1940=head2 $IPC::Cmd::ALLOW_NULL_ARGS
1941
1942This variable controls whether C<run> will remove any empty/null arguments
1943it finds in command arguments.
1944
1945Defaults to false, so it will remove null arguments. Set to true to allow
1946them.
1947
0d4ddeff
RGS
1948=head1 Caveats
1949
1950=over 4
1951
bdd3a62b
JB
1952=item Whitespace and IPC::Open3 / system()
1953
1954When using C<IPC::Open3> or C<system>, if you provide a string as the
1955C<command> argument, it is assumed to be appropriately escaped. You can
1956use the C<QUOTE> constant to use as a portable quote character (see above).
39b09a1b 1957However, if you provide an array reference, special rules apply:
bdd3a62b 1958
39b09a1b 1959If your command contains B<special characters> (< > | &), it will
bdd3a62b
JB
1960be internally stringified before executing the command, to avoid that these
1961special characters are escaped and passed as arguments instead of retaining
1962their special meaning.
0d4ddeff 1963
508236ce 1964However, if the command contained arguments that contained whitespace,
265b802e 1965stringifying the command would lose the significance of the whitespace.
39b09a1b 1966Therefore, C<IPC::Cmd> will quote any arguments containing whitespace in your
bdd3a62b
JB
1967command if the command is passed as an arrayref and contains special characters.
1968
1969=item Whitespace and IPC::Run
1970
508236ce
CBW
1971When using C<IPC::Run>, if you provide a string as the C<command> argument,
1972the string will be split on whitespace to determine the individual elements
bdd3a62b 1973of your command. Although this will usually just Do What You Mean, it may
0d4ddeff
RGS
1974break if you have files or commands with whitespace in them.
1975
1976If you do not wish this to happen, you should provide an array
1977reference, where all parts of your command are already separated out.
39b09a1b 1978Note however, if there are extra or spurious whitespaces in these parts,
0d4ddeff
RGS
1979the parser or underlying code may not interpret it correctly, and
1980cause an error.
1981
1982Example:
1983The following code
1984
1985 gzip -cdf foo.tar.gz | tar -xf -
1986
1987should either be passed as
1988
1989 "gzip -cdf foo.tar.gz | tar -xf -"
1990
1991or as
1992
1993 ['gzip', '-cdf', 'foo.tar.gz', '|', 'tar', '-xf', '-']
1994
1995But take care not to pass it as, for example
1996
1997 ['gzip -cdf foo.tar.gz', '|', 'tar -xf -']
1998
1999Since this will lead to issues as described above.
2000
bdd3a62b 2001
0d4ddeff
RGS
2002=item IO Redirect
2003
2004Currently it is too complicated to parse your command for IO
39b09a1b 2005redirections. For capturing STDOUT or STDERR there is a work around
0d4ddeff
RGS
2006however, since you can just inspect your buffers for the contents.
2007
bdd3a62b
JB
2008=item Interleaving STDOUT/STDERR
2009
2010Neither IPC::Run nor IPC::Open3 can interleave STDOUT and STDERR. For short
39b09a1b 2011bursts of output from a program, e.g. this sample,
bdd3a62b
JB
2012
2013 for ( 1..4 ) {
2014 $_ % 2 ? print STDOUT $_ : print STDERR $_;
2015 }
2016
508236ce 2017IPC::[Run|Open3] will first read all of STDOUT, then all of STDERR, meaning
39b09a1b 2018the output looks like '13' on STDOUT and '24' on STDERR, instead of
bdd3a62b 2019
39b09a1b
CBW
2020 1
2021 2
2022 3
2023 4
bdd3a62b
JB
2024
2025This has been recorded in L<rt.cpan.org> as bug #37532: Unable to interleave
39b09a1b 2026STDOUT and STDERR.
bdd3a62b 2027
0d4ddeff
RGS
2028=back
2029
2030=head1 See Also
2031
39b09a1b 2032L<IPC::Run>, L<IPC::Open3>
0d4ddeff 2033
0d4ddeff
RGS
2034=head1 ACKNOWLEDGEMENTS
2035
2036Thanks to James Mastros and Martijn van der Streek for their
39b09a1b 2037help in getting L<IPC::Open3> to behave nicely.
0d4ddeff 2038
635ccb1c
CBW
2039Thanks to Petya Kohts for the C<run_forked> code.
2040
cce6d045
JB
2041=head1 BUG REPORTS
2042
2043Please report bugs or other issues to E<lt>bug-ipc-cmd@rt.cpan.orgE<gt>.
2044
2045=head1 AUTHOR
2046
39b09a1b
CBW
2047Original author: Jos Boumans E<lt>kane@cpan.orgE<gt>.
2048Current maintainer: Chris Williams E<lt>bingos@cpan.orgE<gt>.
cce6d045 2049
0d4ddeff
RGS
2050=head1 COPYRIGHT
2051
508236ce 2052This library is free software; you may redistribute and/or modify it
cce6d045 2053under the same terms as Perl itself.
0d4ddeff 2054
cce6d045 2055=cut