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['] };
15 use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG
16 $USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN
23 $USE_IPC_RUN = IS_WIN32 && !IS_WIN98;
24 $USE_IPC_OPEN3 = not IS_VMS;
26 $CAN_USE_RUN_FORKED = 0;
28 require POSIX; POSIX->import();
29 require IPC::Open3; IPC::Open3->import();
30 require IO::Select; IO::Select->import();
31 require IO::Handle; IO::Handle->import();
32 require FileHandle; FileHandle->import();
33 require Socket; Socket->import();
34 require Time::HiRes; Time::HiRes->import();
36 $CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32;
39 @EXPORT_OK = qw[can_run run run_forked QUOTE];
44 use Params::Check qw[check];
45 use Text::ParseWords (); # import ONLY if needed!
46 use Module::Load::Conditional qw[can_load];
47 use Locale::Maketext::Simple Style => 'gettext';
53 IPC::Cmd - finding and running system commands made easy
57 use IPC::Cmd qw[can_run run run_forked];
59 my $full_path = can_run('wget') or warn 'wget is not installed!';
61 ### commands can be arrayrefs or strings ###
62 my $cmd = "$full_path -b theregister.co.uk";
63 my $cmd = [$full_path, '-b', 'theregister.co.uk'];
65 ### in scalar context ###
67 if( scalar run( command => $cmd,
72 print "fetched webpage successfully: $buffer\n";
76 ### in list context ###
77 my( $success, $error_code, $full_buf, $stdout_buf, $stderr_buf ) =
78 run( command => $cmd, verbose => 0 );
81 print "this is what the command printed:\n";
82 print join "", @$full_buf;
85 ### check for features
86 print "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3;
87 print "IPC::Run available: " . IPC::Cmd->can_use_ipc_run;
88 print "Can capture buffer: " . IPC::Cmd->can_capture_buffer;
90 ### don't have IPC::Cmd be verbose, ie don't print to stdout or
91 ### stderr when running commands -- default is '0'
92 $IPC::Cmd::VERBOSE = 0;
97 IPC::Cmd allows you to run commands, interactively if desired,
98 platform independent but have them still work.
100 The C<can_run> function can tell you if a certain binary is installed
101 and if so where, whereas the C<run> function can actually execute any
102 of the commands you give it and give you a clear return value, as well
103 as adhere to your verbosity settings.
107 =head2 $ipc_run_version = IPC::Cmd->can_use_ipc_run( [VERBOSE] )
109 Utility function that tells you if C<IPC::Run> is available.
110 If the verbose flag is passed, it will print diagnostic messages
111 if C<IPC::Run> can not be found or loaded.
116 sub can_use_ipc_run {
118 my $verbose = shift || 0;
120 ### ipc::run doesn't run on win98
123 ### if we dont have ipc::run, we obviously can't use it.
124 return unless can_load(
125 modules => { 'IPC::Run' => '0.55' },
126 verbose => ($WARN && $verbose),
129 ### otherwise, we're good to go
130 return $IPC::Run::VERSION;
133 =head2 $ipc_open3_version = IPC::Cmd->can_use_ipc_open3( [VERBOSE] )
135 Utility function that tells you if C<IPC::Open3> is available.
136 If the verbose flag is passed, it will print diagnostic messages
137 if C<IPC::Open3> can not be found or loaded.
142 sub can_use_ipc_open3 {
144 my $verbose = shift || 0;
146 ### ipc::open3 is not working on VMS becasue of a lack of fork.
147 ### XXX todo, win32 also does not have fork, so need to do more research.
150 ### ipc::open3 works on every non-VMS platform platform, but it can't
151 ### capture buffers on win32 :(
152 return unless can_load(
153 modules => { map {$_ => '0.0'} qw|IPC::Open3 IO::Select Symbol| },
154 verbose => ($WARN && $verbose),
157 return $IPC::Open3::VERSION;
160 =head2 $bool = IPC::Cmd->can_capture_buffer
162 Utility function that tells you if C<IPC::Cmd> is capable of
163 capturing buffers in it's current configuration.
167 sub can_capture_buffer {
170 return 1 if $USE_IPC_RUN && $self->can_use_ipc_run;
171 return 1 if $USE_IPC_OPEN3 && $self->can_use_ipc_open3 && !IS_WIN32;
175 =head2 $bool = IPC::Cmd->can_use_run_forked
177 Utility function that tells you if C<IPC::Cmd> is capable of
178 providing C<run_forked> on the current platform.
182 =head2 $path = can_run( PROGRAM );
184 C<can_run> takes but a single argument: the name of a binary you wish
185 to locate. C<can_run> works much like the unix binary C<which> or the bash
186 command C<type>, which scans through your path, looking for the requested
189 Unlike C<which> and C<type>, this function is platform independent and
190 will also work on, for example, Win32.
192 It will return the full path to the binary you asked for if it was
193 found, or C<undef> if it was not.
200 # a lot of VMS executables have a symbol defined
202 if ( $^O eq 'VMS' ) {
204 my $syms = VMS::DCLsym->new;
205 return $command if scalar $syms->getsym( uc $command );
210 require ExtUtils::MakeMaker;
212 if( File::Spec->file_name_is_absolute($command) ) {
213 return MM->maybe_command($command);
217 (split /\Q$Config::Config{path_sep}\E/, $ENV{PATH}),
220 my $abs = File::Spec->catfile($dir, $command);
221 return $abs if $abs = MM->maybe_command($abs);
226 =head2 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR, timeout => DIGIT] );
228 C<run> takes 4 arguments:
234 This is the command to execute. It may be either a string or an array
236 This is a required argument.
238 See L<CAVEATS> for remarks on how commands are parsed and their
243 This controls whether all output of a command should also be printed
244 to STDOUT/STDERR or should only be trapped in buffers (NOTE: buffers
245 require C<IPC::Run> to be installed or your system able to work with
248 It will default to the global setting of C<$IPC::Cmd::VERBOSE>,
249 which by default is 0.
253 This will hold all the output of a command. It needs to be a reference
255 Note that this will hold both the STDOUT and STDERR messages, and you
256 have no way of telling which is which.
257 If you require this distinction, run the C<run> command in list context
258 and inspect the individual buffers.
260 Of course, this requires that the underlying call supports buffers. See
261 the note on buffers right above.
265 Sets the maximum time the command is allowed to run before aborting,
266 using the built-in C<alarm()> call. If the timeout is triggered, the
267 C<errorcode> in the return value will be set to an object of the
268 C<IPC::Cmd::TimeOut> class. See the C<errorcode> section below for
271 Defaults to C<0>, meaning no timeout is set.
275 C<run> will return a simple C<true> or C<false> when called in scalar
277 In list context, you will be returned a list of the following items:
283 A simple boolean indicating if the command executed without errors or
288 If the first element of the return value (success) was 0, then some
289 error occurred. This second element is the error message the command
290 you requested exited with, if available. This is generally a pretty
291 printed value of C<$?> or C<$@>. See C<perldoc perlvar> for details on
292 what they can contain.
293 If the error was a timeout, the C<error message> will be prefixed with
294 the string C<IPC::Cmd::TimeOut>, the timeout class.
298 This is an arrayreference containing all the output the command
300 Note that buffers are only available if you have C<IPC::Run> installed,
301 or if your system is able to work with C<IPC::Open3> -- See below).
302 This element will be C<undef> if this is not the case.
306 This is an arrayreference containing all the output sent to STDOUT the
308 Note that buffers are only available if you have C<IPC::Run> installed,
309 or if your system is able to work with C<IPC::Open3> -- See below).
310 This element will be C<undef> if this is not the case.
314 This is an arrayreference containing all the output sent to STDERR the
316 Note that buffers are only available if you have C<IPC::Run> installed,
317 or if your system is able to work with C<IPC::Open3> -- See below).
318 This element will be C<undef> if this is not the case.
322 See the C<HOW IT WORKS> Section below to see how C<IPC::Cmd> decides
323 what modules or function calls to use when issuing a command.
327 { my @acc = qw[ok error _fds];
329 ### autogenerate accessors ###
330 for my $key ( @acc ) {
332 *{__PACKAGE__."::$key"} = sub {
333 $_[0]->{$key} = $_[1] if @_ > 1;
334 return $_[0]->{$key};
339 sub can_use_run_forked {
340 return $CAN_USE_RUN_FORKED eq "1";
343 # give process a chance sending TERM,
344 # waiting for a while (2 seconds)
345 # and killing it with KILL
352 my $child_finished = 0;
354 while (!$child_finished && $wait_cycles < 8) {
355 my $waitpid = waitpid($pid, WNOHANG);
356 if ($waitpid eq -1) {
360 $wait_cycles = $wait_cycles + 1;
361 Time::HiRes::usleep(250000); # half a second
366 my ($cmd, $opts) = @_;
368 $opts = {} unless $opts;
370 my $child_in = FileHandle->new;
371 my $child_out = FileHandle->new;
372 my $child_err = FileHandle->new;
373 $child_out->autoflush(1);
374 $child_err->autoflush(1);
376 my $pid = open3($child_in, $child_out, $child_err, $cmd);
378 # push my child's pid to our parent
379 # so in case i am killed parent
380 # could stop my child (search for
381 # child_child_pid in parent code)
382 if ($opts->{'parent_info'}) {
383 my $ps = $opts->{'parent_info'};
384 print $ps "spawned $pid\n";
387 if ($child_in && $child_out->opened && $opts->{'child_stdin'}) {
389 # If the child process dies for any reason,
390 # the next write to CHLD_IN is likely to generate
391 # a SIGPIPE in the parent, which is fatal by default.
392 # So you may wish to handle this signal.
394 # from http://perldoc.perl.org/IPC/Open3.html,
395 # absolutely needed to catch piped commands errors.
397 local $SIG{'SIG_PIPE'} = sub { 1; };
399 print $child_in $opts->{'child_stdin'};
404 'out' => $child_out->fileno,
405 'err' => $child_err->fileno,
406 $child_out->fileno => {
407 'parent_socket' => $opts->{'parent_stdout'},
408 'scalar_buffer' => "",
409 'child_handle' => $child_out,
410 'block_size' => ($child_out->stat)[11] || 1024,
412 $child_err->fileno => {
413 'parent_socket' => $opts->{'parent_stderr'},
414 'scalar_buffer' => "",
415 'child_handle' => $child_err,
416 'block_size' => ($child_err->stat)[11] || 1024,
420 my $select = IO::Select->new();
421 $select->add($child_out, $child_err);
423 # pass any signal to the child
424 # effectively creating process
425 # strongly attached to the child:
426 # it will terminate only after child
427 # has terminated (except for SIGKILL,
428 # which is specially handled)
429 foreach my $s (keys %SIG) {
433 $SIG{$s} = $sig_handler;
435 $SIG{$s} = $sig_handler;
438 my $child_finished = 0;
440 my $got_sig_child = 0;
441 $SIG{'CHLD'} = sub { $got_sig_child = time(); };
443 while(!$child_finished && ($child_out->opened || $child_err->opened)) {
445 # parent was killed otherwise we would have got
446 # the same signal as parent and process it same way
447 if (getppid() eq "1") {
452 if ($got_sig_child) {
453 if (time() - $got_sig_child > 10) {
454 print STDERR "select->can_read did not return 0 for 10 seconds after SIG_CHLD, killing [$pid]\n";
460 Time::HiRes::usleep(1);
462 foreach my $fd ($select->can_read(1/100)) {
463 my $str = $child_output->{$fd->fileno};
464 psSnake::die("child stream not found: $fd") unless $str;
467 my $count = $fd->sysread($data, $str->{'block_size'});
470 if ($str->{'parent_socket'}) {
471 my $ph = $str->{'parent_socket'};
475 $str->{'scalar_buffer'} .= $data;
478 elsif ($count eq 0) {
479 $select->remove($fd);
483 psSnake::die("error during sysread: " . $!);
490 # i've successfully reaped my child,
491 # let my parent know this
492 if ($opts->{'parent_info'}) {
493 my $ps = $opts->{'parent_info'};
494 print $ps "reaped $pid\n";
498 my $exit_value = $real_exit >> 8;
499 if ($opts->{'parent_stdout'} || $opts->{'parent_stderr'}) {
504 'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'},
505 'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'},
506 'exit_code' => $exit_value,
511 =head2 $hashref = run_forked( command => COMMAND, { child_stdin => SCALAR, timeout => DIGIT, stdout_handler => CODEREF, stderr_handler => CODEREF} );
513 C<run_forked> is used to execute some program,
514 optionally feed it with some input, get its return code
515 and output (both stdout and stderr into seperate buffers).
516 In addition it allows to terminate the program
517 which take too long to finish.
519 The important and distinguishing feature of run_forked
520 is execution timeout which at first seems to be
521 quite a simple task but if you think
522 that the program which you're spawning
523 might spawn some children itself (which
524 in their turn could do the same and so on)
525 it turns out to be not a simple issue.
527 C<run_forked> is designed to survive and
528 successfully terminate almost any long running task,
529 even a fork bomb in case your system has the resources
530 to survive during given timeout.
532 This is achieved by creating separate watchdog process
533 which spawns the specified program in a separate
534 process session and supervises it: optionally
535 feeds it with input, stores its exit code,
536 stdout and stderr, terminates it in case
537 it runs longer than specified.
539 Invocation requires the command to be executed and optionally a hashref of options:
545 Specify in seconds how long the command may run for before it is killed with with SIG_KILL (9)
546 which effectively terminates it and all of its children (direct or indirect).
550 Specify some text that will be passed into C<STDIN> of the executed program.
552 =item C<stdout_handler>
554 You may provide a coderef of a subroutine that will be called a portion of data is received on
555 stdout from the executing program.
557 =item C<stderr_handler>
559 You may provide a coderef of a subroutine that will be called a portion of data is received on
560 stderr from the executing program.
564 C<run_forked> will return a HASHREF with the following keys:
570 The exit code of the executed program.
574 The number of seconds the program ran for before being terminated, or 0 if no timeout occurred.
578 Holds the standard output of the executed command
579 (or empty string if there were no stdout output; it's always defined!)
583 Holds the standard error of the executed command
584 (or empty string if there were no stderr output; it's always defined!)
588 Holds the standard output and error of the executed command merged into one stream
589 (or empty string if there were no output at all; it's always defined!)
593 Holds some explanation in the case of an error.
600 ### container to store things in
601 my $self = bless {}, __PACKAGE__;
603 if (!can_use_run_forked()) {
604 Carp::carp("run_forked is not available: $CAN_USE_RUN_FORKED");
608 my ($cmd, $opts) = @_;
611 Carp::carp("run_forked expects command to run");
615 $opts = {} unless $opts;
616 $opts->{'timeout'} = 0 unless $opts->{'timeout'};
618 # sockets to pass child stdout to parent
619 my $child_stdout_socket;
620 my $parent_stdout_socket;
622 # sockets to pass child stderr to parent
623 my $child_stderr_socket;
624 my $parent_stderr_socket;
626 # sockets for child -> parent internal communication
627 my $child_info_socket;
628 my $parent_info_socket;
630 socketpair($child_stdout_socket, $parent_stdout_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
631 die ("socketpair: $!");
632 socketpair($child_stderr_socket, $parent_stderr_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
633 die ("socketpair: $!");
634 socketpair($child_info_socket, $parent_info_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
635 die ("socketpair: $!");
637 $child_stdout_socket->autoflush(1);
638 $parent_stdout_socket->autoflush(1);
639 $child_stderr_socket->autoflush(1);
640 $parent_stderr_socket->autoflush(1);
641 $child_info_socket->autoflush(1);
642 $parent_info_socket->autoflush(1);
644 my $start_time = time();
650 close($parent_stdout_socket);
651 close($parent_stderr_socket);
652 close($parent_info_socket);
654 my $child_timedout = 0;
657 # prepare sockets to read from child
660 fcntl($child_stdout_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
661 $flags |= O_NONBLOCK;
662 fcntl($child_stdout_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
665 fcntl($child_stderr_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
666 $flags |= O_NONBLOCK;
667 fcntl($child_stderr_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
670 fcntl($child_info_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
671 $flags |= O_NONBLOCK;
672 fcntl($child_info_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
674 # print "child $pid started\n";
676 my $child_finished = 0;
677 my $child_stdout = '';
678 my $child_stderr = '';
679 my $child_merged = '';
680 my $child_exit_code = 0;
682 my $got_sig_child = 0;
683 $SIG{'CHLD'} = sub { $got_sig_child = time(); };
687 while (!$child_finished) {
688 # user specified timeout
689 if ($opts->{'timeout'}) {
690 if (time() - $start_time > $opts->{'timeout'}) {
696 # give OS 10 seconds for correct return of waitpid,
697 # kill process after that and finish wait loop;
698 # shouldn't ever happen -- remove this code?
699 if ($got_sig_child) {
700 if (time() - $got_sig_child > 10) {
701 print STDERR "waitpid did not return -1 for 10 seconds after SIG_CHLD, killing [$pid]\n";
707 my $waitpid = waitpid($pid, WNOHANG);
709 # child finished, catch it's exit status
710 if ($waitpid ne 0 && $waitpid ne -1) {
711 $child_exit_code = $? >> 8;
714 if ($waitpid eq -1) {
719 # child -> parent simple internal communication protocol
720 while (my $l = <$child_info_socket>) {
721 if ($l =~ /^spawned ([0-9]+?)\n(.*?)/so) {
722 $child_child_pid = $1;
725 if ($l =~ /^reaped ([0-9]+?)\n(.*?)/so) {
726 $child_child_pid = undef;
731 while (my $l = <$child_stdout_socket>) {
735 if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') {
736 $opts->{'stdout_handler'}->($l);
739 while (my $l = <$child_stderr_socket>) {
743 if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') {
744 $opts->{'stderr_handler'}->($l);
748 Time::HiRes::usleep(1);
751 # $child_pid_pid is not defined in two cases:
752 # * when our child was killed before
753 # it had chance to tell us the pid
754 # of the child it spawned. we can do
755 # nothing in this case :(
756 # * our child successfully reaped its child,
757 # we have nothing left to do in this case
759 # defined $child_pid_pid means child's child
760 # has not died but nobody is waiting for it,
761 # killing it brutaly.
763 if ($child_child_pid) {
764 kill_gently($child_child_pid);
767 # print "child $pid finished\n";
769 close($child_stdout_socket);
770 close($child_stderr_socket);
771 close($child_info_socket);
774 'stdout' => $child_stdout,
775 'stderr' => $child_stderr,
776 'merged' => $child_merged,
777 'timeout' => $child_timedout ? $opts->{'timeout'} : 0,
778 'exit_code' => $child_exit_code,
782 if ($o->{'exit_code'}) {
783 $err_msg .= "exited with code [$o->{'exit_code'}]\n";
785 if ($o->{'timeout'}) {
786 $err_msg .= "ran more than [$o->{'timeout'}] seconds\n";
788 if ($o->{'stdout'}) {
789 $err_msg .= "stdout:\n" . $o->{'stdout'} . "\n";
791 if ($o->{'stderr'}) {
792 $err_msg .= "stderr:\n" . $o->{'stderr'} . "\n";
794 $o->{'err_msg'} = $err_msg;
799 die("cannot fork: $!") unless defined($pid);
801 # create new process session for open3 call,
802 # so we hopefully can kill all the subprocesses
803 # which might be spawned in it (except for those
804 # which do setsid theirselves -- can't do anything
807 POSIX::setsid() || die("Error running setsid: " . $!);
809 close($child_stdout_socket);
810 close($child_stderr_socket);
811 close($child_info_socket);
813 my $child_exit_code = open3_run($cmd, {
814 'parent_info' => $parent_info_socket,
815 'parent_stdout' => $parent_stdout_socket,
816 'parent_stderr' => $parent_stderr_socket,
817 'child_stdin' => $opts->{'child_stdin'},
820 close($parent_stdout_socket);
821 close($parent_stderr_socket);
822 close($parent_info_socket);
824 exit $child_exit_code;
829 ### container to store things in
830 my $self = bless {}, __PACKAGE__;
834 ### if the user didn't provide a buffer, we'll store it here.
837 my($verbose,$cmd,$buffer,$timeout);
839 verbose => { default => $VERBOSE, store => \$verbose },
840 buffer => { default => \$def_buf, store => \$buffer },
841 command => { required => 1, store => \$cmd,
842 allow => sub { !ref($_[0]) or ref($_[0]) eq 'ARRAY' },
844 timeout => { default => 0, store => \$timeout },
847 unless( check( $tmpl, \%hash, $VERBOSE ) ) {
848 Carp::carp( loc( "Could not validate input: %1",
849 Params::Check->last_error ) );
853 $cmd = _quote_args_vms( $cmd ) if IS_VMS;
855 ### strip any empty elements from $cmd if present
856 $cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
858 my $pp_cmd = (ref $cmd ? "@$cmd" : $cmd);
859 print loc("Running [%1]...\n", $pp_cmd ) if $verbose;
861 ### did the user pass us a buffer to fill or not? if so, set this
862 ### flag so we know what is expected of us
863 ### XXX this is now being ignored. in the future, we could add diagnostic
864 ### messages based on this logic
865 #my $user_provided_buffer = $buffer == \$def_buf ? 0 : 1;
867 ### buffers that are to be captured
868 my( @buffer, @buff_err, @buff_out );
871 my $_out_handler = sub {
873 return unless defined $buf;
875 print STDOUT $buf if $verbose;
877 push @buff_out, $buf;
881 my $_err_handler = sub {
883 return unless defined $buf;
885 print STDERR $buf if $verbose;
887 push @buff_err, $buf;
891 ### flag to indicate we have a buffer captured
892 my $have_buffer = $self->can_capture_buffer ? 1 : 0;
894 ### flag indicating if the subcall went ok
897 ### dont look at previous errors:
902 ### we might be having a timeout set
904 local $SIG{ALRM} = sub { die bless sub {
906 qq[: Command '$pp_cmd' aborted by alarm after $timeout seconds]
907 }, ALARM_CLASS } if $timeout;
910 ### IPC::Run is first choice if $USE_IPC_RUN is set.
911 if( $USE_IPC_RUN and $self->can_use_ipc_run( 1 ) ) {
912 ### ipc::run handlers needs the command as a string or an array ref
914 $self->_debug( "# Using IPC::Run. Have buffer: $have_buffer" )
917 $ok = $self->_ipc_run( $cmd, $_out_handler, $_err_handler );
919 ### since IPC::Open3 works on all platforms, and just fails on
920 ### win32 for capturing buffers, do that ideally
921 } elsif ( $USE_IPC_OPEN3 and $self->can_use_ipc_open3( 1 ) ) {
923 $self->_debug("# Using IPC::Open3. Have buffer: $have_buffer")
926 ### in case there are pipes in there;
927 ### IPC::Open3 will call exec and exec will do the right thing
928 $ok = $self->_open3_run(
929 $cmd, $_out_handler, $_err_handler, $verbose
932 ### if we are allowed to run verbose, just dispatch the system command
934 $self->_debug( "# Using system(). Have buffer: $have_buffer" )
936 $ok = $self->_system_run( $cmd, $verbose );
942 ### restore STDIN after duping, or STDIN will be closed for
943 ### this current perl process!
944 $self->__reopen_fds( @{ $self->_fds} ) if $self->_fds;
949 if ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) {
950 $err = $@->(); # the error code is an expired alarm
952 ### another error happened, set by the dispatchub
959 $$buffer = join '', @buffer if @buffer;
961 ### return a list of flags and buffers (if available) in list
962 ### context, or just a simple 'ok' in scalar
965 ? ($ok, $err, \@buffer, \@buff_out, \@buff_err)
975 my $_out_handler = shift;
976 my $_err_handler = shift;
977 my $verbose = shift || 0;
979 ### Following code are adapted from Friar 'abstracts' in the
980 ### Perl Monastery (http://www.perlmonks.org/index.pl?node_id=151886).
981 ### XXX that code didn't work.
982 ### we now use the following code, thanks to theorbtwo
984 ### define them beforehand, so we always have defined FH's
987 my $kidout = Symbol::gensym();
988 my $kiderror = Symbol::gensym();
990 ### Dup the filehandle so we can pass 'our' STDIN to the
991 ### child process. This stops us from having to pump input
992 ### from ourselves to the childprocess. However, we will need
993 ### to revive the FH afterwards, as IPC::Open3 closes it.
994 ### We'll do the same for STDOUT and STDERR. It works without
995 ### duping them on non-unix derivatives, but not on win32.
996 my @fds_to_dup = ( IS_WIN32 && !$verbose
997 ? qw[STDIN STDOUT STDERR]
1000 $self->_fds( \@fds_to_dup );
1001 $self->__dup_fds( @fds_to_dup );
1003 ### pipes have to come in a quoted string, and that clashes with
1004 ### whitespace. This sub fixes up such commands so they run properly
1005 $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
1007 ### dont stringify @$cmd, so spaces in filenames/paths are
1008 ### treated properly
1012 (IS_WIN32 ? '>&STDOUT' : $kidout),
1013 (IS_WIN32 ? '>&STDERR' : $kiderror),
1014 ( ref $cmd ? @$cmd : $cmd ),
1018 ### open3 error occurred
1019 if( $@ and $@ =~ /^open3:/ ) {
1025 ### use OUR stdin, not $kidin. Somehow,
1026 ### we never get the input.. so jump through
1027 ### some hoops to do it :(
1028 my $selector = IO::Select->new(
1029 (IS_WIN32 ? \*STDERR : $kiderror),
1031 (IS_WIN32 ? \*STDOUT : $kidout)
1034 STDOUT->autoflush(1); STDERR->autoflush(1); STDIN->autoflush(1);
1035 $kidout->autoflush(1) if UNIVERSAL::can($kidout, 'autoflush');
1036 $kiderror->autoflush(1) if UNIVERSAL::can($kiderror, 'autoflush');
1038 ### add an epxlicit break statement
1039 ### code courtesy of theorbtwo from #london.pm
1040 my $stdout_done = 0;
1041 my $stderr_done = 0;
1042 OUTER: while ( my @ready = $selector->can_read ) {
1044 for my $h ( @ready ) {
1047 ### $len is the amount of bytes read
1048 my $len = sysread( $h, $buf, 4096 ); # try to read 4096 bytes
1050 ### see perldoc -f sysread: it returns undef on error,
1052 if( not defined $len ) {
1053 warn(loc("Error reading from process: %1", $!));
1057 ### check for $len. it may be 0, at which point we're
1058 ### done reading, so don't try to process it.
1059 ### if we would print anyway, we'd provide bogus information
1060 $_out_handler->( "$buf" ) if $len && $h == $kidout;
1061 $_err_handler->( "$buf" ) if $len && $h == $kiderror;
1063 ### Wait till child process is done printing to both
1064 ### stdout and stderr.
1065 $stdout_done = 1 if $h == $kidout and $len == 0;
1066 $stderr_done = 1 if $h == $kiderror and $len == 0;
1067 last OUTER if ($stdout_done && $stderr_done);
1071 waitpid $pid, 0; # wait for it to die
1073 ### restore STDIN after duping, or STDIN will be closed for
1074 ### this current perl process!
1075 ### done in the parent call now
1076 # $self->__reopen_fds( @fds_to_dup );
1078 ### some error occurred
1080 $self->error( $self->_pp_child_error( $cmd, $? ) );
1084 return $self->ok( 1 );
1088 ### text::parsewords::shellwordss() uses unix semantics. that will break
1090 { my $parse_sub = IS_WIN32
1091 ? __PACKAGE__->can('_split_like_shell_win32')
1092 : Text::ParseWords->can('shellwords');
1097 my $_out_handler = shift;
1098 my $_err_handler = shift;
1100 STDOUT->autoflush(1); STDERR->autoflush(1);
1106 # '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz',
1111 ### needs to become:
1113 # ['/usr/bin/gzip', '-cdf',
1114 # '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz']
1116 # ['/usr/bin/tar', '-tf -']
1123 my $re = do { my $x = join '', SPECIAL_CHARS; qr/([$x])/ };
1126 for my $item (@$cmd) {
1127 if( $item =~ $re ) {
1128 push @command, $aref, $item;
1130 $special_chars .= $1;
1135 push @command, $aref;
1137 @command = map { if( $_ =~ $re ) {
1138 $special_chars .= $1; $_;
1141 [ map { m/[ ]/ ? qq{'$_'} : $_ } $parse_sub->($_) ]
1143 } split( /\s*$re\s*/, $cmd );
1146 ### if there's a pipe in the command, *STDIN needs to
1147 ### be inserted *BEFORE* the pipe, to work on win32
1148 ### this also works on *nix, so we should do it when possible
1149 ### this should *also* work on multiple pipes in the command
1150 ### if there's no pipe in the command, append STDIN to the back
1151 ### of the command instead.
1152 ### XXX seems IPC::Run works it out for itself if you just
1153 ### dont pass STDIN at all.
1154 # if( $special_chars and $special_chars =~ /\|/ ) {
1155 # ### only add STDIN the first time..
1157 # @command = map { ($_ eq '|' && not $i++)
1162 # push @command, \*STDIN;
1165 # \*STDIN is already included in the @command, see a few lines up
1166 my $ok = eval { IPC::Run::run( @command,
1176 return $self->ok( $ok );
1178 ### some error occurred
1182 ### if the eval fails due to an exception, deal with it
1183 ### unless it's an alarm
1184 if( $@ and not UNIVERSAL::isa( $@, ALARM_CLASS ) ) {
1187 ### if it *is* an alarm, propagate
1191 ### some error in the sub command
1193 $self->error( $self->_pp_child_error( $cmd, $? ) );
1204 my $verbose = shift || 0;
1206 ### pipes have to come in a quoted string, and that clashes with
1207 ### whitespace. This sub fixes up such commands so they run properly
1208 $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
1210 my @fds_to_dup = $verbose ? () : qw[STDOUT STDERR];
1211 $self->_fds( \@fds_to_dup );
1212 $self->__dup_fds( @fds_to_dup );
1214 ### system returns 'true' on failure -- the exit code of the cmd
1216 system( ref $cmd ? @$cmd : $cmd ) == 0 or do {
1217 $self->error( $self->_pp_child_error( $cmd, $? ) );
1221 ### done in the parent call now
1222 #$self->__reopen_fds( @fds_to_dup );
1224 return unless $self->ok;
1228 { my %sc_lookup = map { $_ => $_ } SPECIAL_CHARS;
1231 sub __fix_cmd_whitespace_and_special_chars {
1235 ### command has a special char in it
1236 if( ref $cmd and grep { $sc_lookup{$_} } @$cmd ) {
1238 ### since we have special chars, we have to quote white space
1239 ### this *may* conflict with the parsing :(
1241 my @cmd = map { / / ? do { $fixed++; QUOTE.$_.QUOTE } : $_ } @$cmd;
1243 $self->_debug( "# Quoted $fixed arguments containing whitespace" )
1244 if $DEBUG && $fixed;
1246 ### stringify it, so the special char isn't escaped as argument
1248 $cmd = join ' ', @cmd;
1255 ### Command-line arguments (but not the command itself) must be quoted
1256 ### to ensure case preservation. Borrowed from Module::Build with adaptations.
1257 ### Patch for this supplied by Craig Berry, see RT #46288: [PATCH] Add argument
1258 ### quoting for run() on VMS
1259 sub _quote_args_vms {
1260 ### Returns a command string with proper quoting so that the subprocess
1261 ### sees this same list of args, or if we get a single arg that is an
1262 ### array reference, quote the elements of it (except for the first)
1263 ### and return the reference.
1265 my $got_arrayref = (scalar(@args) == 1
1266 && UNIVERSAL::isa($args[0], 'ARRAY'))
1270 @args = split(/\s+/, $args[0]) unless $got_arrayref || scalar(@args) > 1;
1272 my $cmd = $got_arrayref ? shift @{$args[0]} : shift @args;
1274 ### Do not quote qualifiers that begin with '/' or previously quoted args.
1275 map { if (/^[^\/\"]/) {
1276 $_ =~ s/\"/""/g; # escape C<"> by doubling
1280 ($got_arrayref ? @{$args[0]}
1284 $got_arrayref ? unshift(@{$args[0]}, $cmd) : unshift(@args, $cmd);
1286 return $got_arrayref ? $args[0]
1291 ### XXX this is cribbed STRAIGHT from M::B 0.30 here:
1292 ### http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell
1293 ### XXX this *should* be integrated into text::parsewords
1294 sub _split_like_shell_win32 {
1295 # As it turns out, Windows command-parsing is very different from
1296 # Unix command-parsing. Double-quotes mean different things,
1297 # backslashes don't necessarily mean escapes, and so on. So we
1298 # can't use Text::ParseWords::shellwords() to break a command string
1299 # into words. The algorithm below was bashed out by Randy and Ken
1300 # (mostly Randy), and there are a lot of regression tests, so we
1301 # should feel free to adjust if desired.
1306 return @argv unless defined() && length();
1309 my( $i, $quote_mode ) = ( 0, 0 );
1311 while ( $i < length() ) {
1313 my $ch = substr( $_, $i , 1 );
1314 my $next_ch = substr( $_, $i+1, 1 );
1316 if ( $ch eq '\\' && $next_ch eq '"' ) {
1319 } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
1322 } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
1323 $quote_mode = !$quote_mode;
1326 } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
1327 ( $i + 2 == length() ||
1328 substr( $_, $i + 2, 1 ) eq ' ' )
1329 ) { # for cases like: a"" => [ 'a' ]
1330 push( @argv, $arg );
1333 } elsif ( $ch eq '"' ) {
1334 $quote_mode = !$quote_mode;
1335 } elsif ( $ch eq ' ' && !$quote_mode ) {
1336 push( @argv, $arg ) if $arg;
1338 ++$i while substr( $_, $i + 1, 1 ) eq ' ';
1346 push( @argv, $arg ) if defined( $arg ) && length( $arg );
1356 STDOUT => [qw|>&|, \*STDOUT, Symbol::gensym() ],
1357 STDERR => [qw|>&|, \*STDERR, Symbol::gensym() ],
1358 STDIN => [qw|<&|, \*STDIN, Symbol::gensym() ],
1361 ### dups FDs and stores them in a cache
1366 __PACKAGE__->_debug( "# Closing the following fds: @fds" ) if $DEBUG;
1368 for my $name ( @fds ) {
1369 my($redir, $fh, $glob) = @{$Map{$name}} or (
1370 Carp::carp(loc("No such FD: '%1'", $name)), next );
1372 ### MUST use the 2-arg version of open for dup'ing for
1373 ### 5.6.x compatibilty. 5.8.x can use 3-arg open
1374 ### see perldoc5.6.2 -f open for details
1375 open $glob, $redir . fileno($fh) or (
1376 Carp::carp(loc("Could not dup '$name': %1", $!)),
1380 ### we should re-open this filehandle right now, not
1382 ### Use 2-arg version of open, as 5.5.x doesn't support
1383 ### 3-arg version =/
1384 if( $redir eq '>&' ) {
1385 open( $fh, '>' . File::Spec->devnull ) or (
1386 Carp::carp(loc("Could not reopen '$name': %1", $!)),
1395 ### reopens FDs from the cache
1400 __PACKAGE__->_debug( "# Reopening the following fds: @fds" ) if $DEBUG;
1402 for my $name ( @fds ) {
1403 my($redir, $fh, $glob) = @{$Map{$name}} or (
1404 Carp::carp(loc("No such FD: '%1'", $name)), next );
1406 ### MUST use the 2-arg version of open for dup'ing for
1407 ### 5.6.x compatibilty. 5.8.x can use 3-arg open
1408 ### see perldoc5.6.2 -f open for details
1409 open( $fh, $redir . fileno($glob) ) or (
1410 Carp::carp(loc("Could not restore '$name': %1", $!)),
1414 ### close this FD, we're not using it anymore
1424 my $msg = shift or return;
1425 my $level = shift || 0;
1427 local $Carp::CarpLevel += $level;
1433 sub _pp_child_error {
1435 my $cmd = shift or return;
1436 my $ce = shift or return;
1437 my $pp_cmd = ref $cmd ? "@$cmd" : $cmd;
1442 ### Include $! in the error message, so that the user can
1443 ### see 'No such file or directory' versus 'Permission denied'
1444 ### versus 'Cannot fork' or whatever the cause was.
1445 $str = "Failed to execute '$pp_cmd': $!";
1447 } elsif ( $ce & 127 ) {
1449 $str = loc( "'%1' died with signal %d, %s coredump\n",
1450 $pp_cmd, ($ce & 127), ($ce & 128) ? 'with' : 'without');
1453 ### Otherwise, the command run but gave error status.
1454 $str = "'$pp_cmd' exited with value " . ($ce >> 8);
1457 $self->_debug( "# Child error '$ce' translated to: $str" ) if $DEBUG;
1466 Returns the character used for quoting strings on this platform. This is
1467 usually a C<'> (single quote) on most systems, but some systems use different
1468 quotes. For example, C<Win32> uses C<"> (double quote).
1470 You can use it as follows:
1472 use IPC::Cmd qw[run QUOTE];
1473 my $cmd = q[echo ] . QUOTE . q[foo bar] . QUOTE;
1475 This makes sure that C<foo bar> is treated as a string, rather than two
1476 seperate arguments to the C<echo> function.
1482 C<run> will try to execute your command using the following logic:
1488 If you have C<IPC::Run> installed, and the variable C<$IPC::Cmd::USE_IPC_RUN>
1489 is set to true (See the C<GLOBAL VARIABLES> Section) use that to execute
1490 the command. You will have the full output available in buffers, interactive commands are sure to work and you are guaranteed to have your verbosity
1491 settings honored cleanly.
1495 Otherwise, if the variable C<$IPC::Cmd::USE_IPC_OPEN3> is set to true
1496 (See the C<GLOBAL VARIABLES> Section), try to execute the command using
1497 C<IPC::Open3>. Buffers will be available on all platforms except C<Win32>,
1498 interactive commands will still execute cleanly, and also your verbosity
1499 settings will be adhered to nicely;
1503 Otherwise, if you have the verbose argument set to true, we fall back
1504 to a simple system() call. We cannot capture any buffers, but
1505 interactive commands will still work.
1509 Otherwise we will try and temporarily redirect STDERR and STDOUT, do a
1510 system() call with your command and then re-open STDERR and STDOUT.
1511 This is the method of last resort and will still allow you to execute
1512 your commands cleanly. However, no buffers will be available.
1516 =head1 Global Variables
1518 The behaviour of IPC::Cmd can be altered by changing the following
1521 =head2 $IPC::Cmd::VERBOSE
1523 This controls whether IPC::Cmd will print any output from the
1524 commands to the screen or not. The default is 0;
1526 =head2 $IPC::Cmd::USE_IPC_RUN
1528 This variable controls whether IPC::Cmd will try to use L<IPC::Run>
1529 when available and suitable. Defaults to true if you are on C<Win32>.
1531 =head2 $IPC::Cmd::USE_IPC_OPEN3
1533 This variable controls whether IPC::Cmd will try to use L<IPC::Open3>
1534 when available and suitable. Defaults to true.
1536 =head2 $IPC::Cmd::WARN
1538 This variable controls whether run time warnings should be issued, like
1539 the failure to load an C<IPC::*> module you explicitly requested.
1541 Defaults to true. Turn this off at your own risk.
1547 =item Whitespace and IPC::Open3 / system()
1549 When using C<IPC::Open3> or C<system>, if you provide a string as the
1550 C<command> argument, it is assumed to be appropriately escaped. You can
1551 use the C<QUOTE> constant to use as a portable quote character (see above).
1552 However, if you provide and C<Array Reference>, special rules apply:
1554 If your command contains C<Special Characters> (< > | &), it will
1555 be internally stringified before executing the command, to avoid that these
1556 special characters are escaped and passed as arguments instead of retaining
1557 their special meaning.
1559 However, if the command contained arguments that contained whitespace,
1560 stringifying the command would loose the significance of the whitespace.
1561 Therefor, C<IPC::Cmd> will quote any arguments containing whitespace in your
1562 command if the command is passed as an arrayref and contains special characters.
1564 =item Whitespace and IPC::Run
1566 When using C<IPC::Run>, if you provide a string as the C<command> argument,
1567 the string will be split on whitespace to determine the individual elements
1568 of your command. Although this will usually just Do What You Mean, it may
1569 break if you have files or commands with whitespace in them.
1571 If you do not wish this to happen, you should provide an array
1572 reference, where all parts of your command are already separated out.
1573 Note however, if there's extra or spurious whitespace in these parts,
1574 the parser or underlying code may not interpret it correctly, and
1580 gzip -cdf foo.tar.gz | tar -xf -
1582 should either be passed as
1584 "gzip -cdf foo.tar.gz | tar -xf -"
1588 ['gzip', '-cdf', 'foo.tar.gz', '|', 'tar', '-xf', '-']
1590 But take care not to pass it as, for example
1592 ['gzip -cdf foo.tar.gz', '|', 'tar -xf -']
1594 Since this will lead to issues as described above.
1599 Currently it is too complicated to parse your command for IO
1600 Redirections. For capturing STDOUT or STDERR there is a work around
1601 however, since you can just inspect your buffers for the contents.
1603 =item Interleaving STDOUT/STDERR
1605 Neither IPC::Run nor IPC::Open3 can interleave STDOUT and STDERR. For short
1606 bursts of output from a program, ie this sample:
1609 $_ % 2 ? print STDOUT $_ : print STDERR $_;
1612 IPC::[Run|Open3] will first read all of STDOUT, then all of STDERR, meaning
1613 the output looks like 1 line on each, namely '13' on STDOUT and '24' on STDERR.
1615 It should have been 1, 2, 3, 4.
1617 This has been recorded in L<rt.cpan.org> as bug #37532: Unable to interleave
1624 C<IPC::Run>, C<IPC::Open3>
1626 =head1 ACKNOWLEDGEMENTS
1628 Thanks to James Mastros and Martijn van der Streek for their
1629 help in getting IPC::Open3 to behave nicely.
1631 Thanks to Petya Kohts for the C<run_forked> code.
1635 Please report bugs or other issues to E<lt>bug-ipc-cmd@rt.cpan.orgE<gt>.
1639 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1643 This library is free software; you may redistribute and/or modify it
1644 under the same terms as Perl itself.