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