view release on metacpan or  search on metacpan

inc/bundle/IPC/Cmd.pm  view on Meta::CPAN

            if (!$opts->{'discard_output'}) {
              $child_stdout .= $data;
              $child_merged .= $data;
            }

            if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') {
              $opts->{'stdout_handler'}->($data);
            }
          }
          if ($str->{'protocol'} eq 'stderr') {
            if (!$opts->{'discard_output'}) {
              $child_stderr .= $data;
              $child_merged .= $data;
            }

            if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') {
              $opts->{'stderr_handler'}->($data);
            }
          }
 
          # process may finish (waitpid returns -1) before
          # we've read all of its output because of buffering;
          # so try to read all the way it is possible to read
          # in such case - this shouldn't be too much (unless
          # the buffer size is HUGE -- should introduce
          # another counter in such case, maybe later)
          #
          push @{$ready_fds}, $select->can_read(1/100) if $child_finished;
        }

        if ($opts->{'wait_loop_callback'} && ref($opts->{'wait_loop_callback'}) eq 'CODE') {
          $opts->{'wait_loop_callback'}->();
        }

        Time::HiRes::usleep(1);
      }

      # $child_pid_pid is not defined in two cases:
      #  * when our child was killed before
      #    it had chance to tell us the pid
      #    of the child it spawned. we can do
      #    nothing in this case :(
      #  * our child successfully reaped its child,
      #    we have nothing left to do in this case
      #
      # defined $child_pid_pid means child's child
      # has not died but nobody is waiting for it,
      # killing it brutally.
      #
      if ($child_child_pid) {
        kill_gently($child_child_pid);
      }

      # in case there are forks in child which
      # do not forward or process signals (TERM) correctly
      # kill whole child process group, effectively trying
      # not to return with some children or their parts still running
      #
      # to be more accurate -- we need to be sure
      # that this is process group created by our child
      # (and not some other process group with the same pgid,
      # created just after death of our child) -- fortunately
      # this might happen only when process group ids
      # are reused quickly (there are lots of processes
      # spawning new process groups for example)
      #
      if ($opts->{'clean_up_children'}) {
        kill(-9, $pid);
      }

  #    print "child $pid finished\n";

      close($child_stdout_socket);
      close($child_stderr_socket);
      close($child_info_socket);

      my $o = {
        'stdout' => $child_stdout,
        'stderr' => $child_stderr,
        'merged' => $child_merged,
        'timeout' => $child_timedout ? $opts->{'timeout'} : 0,
        'exit_code' => $child_exit_code,
        'parent_died' => $parent_died,
        'killed_by_signal' => $child_killed_by_signal,
        'child_pgid' => $pid,
        'cmd' => $cmd,
        };

      my $err_msg = '';
      if ($o->{'exit_code'}) {
        $err_msg .= "exited with code [$o->{'exit_code'}]\n";
      }
      if ($o->{'timeout'}) {
        $err_msg .= "ran more than [$o->{'timeout'}] seconds\n";
      }
      if ($o->{'parent_died'}) {
        $err_msg .= "parent died\n";
      }
      if ($o->{'stdout'} && !$opts->{'non_empty_stdout_ok'}) {
        $err_msg .= "stdout:\n" . $o->{'stdout'} . "\n";
      }
      if ($o->{'stderr'}) {
        $err_msg .= "stderr:\n" . $o->{'stderr'} . "\n";
      }
      if ($o->{'killed_by_signal'}) {
        $err_msg .= "killed by signal [" . $o->{'killed_by_signal'} . "]\n";
      }
      $o->{'err_msg'} = $err_msg;

      if ($orig_sig_child) {
        $SIG{'CHLD'} = $orig_sig_child;
      }
      else {
        delete($SIG{'CHLD'});
      }

      uninstall_signals();

      return $o;
    }
    else {
      Carp::confess("cannot fork: $!") unless defined($pid);

      # create new process session for open3 call,
      # so we hopefully can kill all the subprocesses
      # which might be spawned in it (except for those
      # which do setsid theirselves -- can't do anything
      # with those)

      POSIX::setsid() == -1 and Carp::confess("Error running setsid: " . $!);

      if ($opts->{'child_BEGIN'} && ref($opts->{'child_BEGIN'}) eq 'CODE') {
        $opts->{'child_BEGIN'}->();
      }

      close($child_stdout_socket);
      close($child_stderr_socket);
      close($child_info_socket);

      my $child_exit_code;

      # allow both external programs
      # and internal perl calls
      if (!ref($cmd)) {
        $child_exit_code = open3_run($cmd, {