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