cpan/IPC-Cmd/lib/IPC/Cmd.pm

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