"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/IPC/Cmd.pm" (7 Mar 2020, 67584 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

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