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