view release on metacpan or  search on metacpan

lib/Fugu/Process.pm  view on Meta::CPAN

			}

			close $in_w;

			open STDIN, '<&', $in_r
			    or _fail( $exec_w, "Cannot redirect stdin: $!" );
		} );

	close $in_r;
	if ($error) {
		close $in_w;
		return _run_error($error);
	}

	{
		local $SIG{PIPE} = 'IGNORE';
		print {$in_w} $input if defined $input && length $input;
	}
	close $in_w;

	my $timed_out = 0;
	if ( defined $timeout ) {
		unless ( $class->wait_exit( $pid, $timeout ) ) {
			$class->terminate(
				$pid,
				grace_period => 1,
				group        => $new_session
			);
			$timed_out = 1;
		}
	}

	waitpid $pid, 0;
	my $code = $class->exit_code($?);

	return {
		success   => ( !$timed_out && $code == 0 ) ? 1 : 0,
		stdout    => '',
		stderr    => '',
		exit_code => $code,
		timed_out => $timed_out,
	};
}

# $class->exit_code($status):
#	Map a raw system() or $? wait status to a 0-255 exit code. The
#	low byte encodes the terminating signal. The high byte encodes
#	the exit code. system() returns -1 when it cannot start the
#	child at all.
#
#	A caller that passes the raw status on to exit() turns a remote
#	exit code of 1 into exit(256), which the kernel truncates to 0.
#	That silently reports a failed command as a success.
sub exit_code ( $class, $status )
{
	return EXIT_ERROR               if $status == -1;
	return 128 + ( $status & 0x7f ) if $status & 0x7f;
	return $status >> 8;
}

# $class->is_alive($pid):
#	Check if the process is alive (not dead, not a zombie).
#	The method returns 1 if the process is alive. It returns 0 if
#	the process is dead, a zombie, or does not exist.
#
#	The check reaps: a zombie child of the caller is collected
#	here, and the answer is 0. A caller that needs the exit status
#	uses run, or waits itself.
sub is_alive ( $class, $pid )
{
	return 0 unless defined $pid;
	return 0 unless $pid =~ /^\d+$/;

	# First check if the process exists
	return 0 unless kill( 0, $pid );

	# Do not try to wait on the current process
	return 1 if $pid == $$;

	# Try to reap zombies without blocking
	my $result = waitpid( $pid, WNOHANG );

	# If waitpid returns the PID, the process was a zombie.
	# waitpid has now reaped it.
	return 0 if $result == $pid;

	# If waitpid returns -1, the process is not a child of the
	# caller. kill(0) already proved that it exists, so it is alive.
	return 1;
}

# $class->terminate($pid, %args):
#	Stop a process gracefully. Use force if necessary.
#	The method returns 1 if the process is killed or dead. It
#	returns 0 on failure.
#
#	%args:
#		grace_period => $seconds # Time to wait after TERM before KILL (default: 5)
#		on_kill      => sub()    # Runs after a successful kill
#		group        => 0|1      # Signal the process group of $pid
#
#	The wait polls with sub-second granularity, so a child that
#	stops at once does not cost a whole second.
#
#	With group each signal goes to the process group of $pid, and
#	$pid must be the pid of a process-group leader. The liveness
#	test is then kill 0 on the group, because a group can outlive
#	its leader, so the group form must not return early on a dead
#	leader. The method cannot wait for a member that is not its
#	child. A member that init has yet to reap can therefore still
#	answer for a moment.
sub terminate ( $class, $pid, %args )
{
	return $class->_terminate_group( $pid, %args ) if $args{group};

	return 1 unless $class->is_alive($pid);

	my $grace_period = $args{grace_period} // 5;
	my $on_kill      = $args{on_kill};

	# Send SIGTERM
	my $killed = kill 'TERM', $pid;
	unless ($killed) {

		# The process is already dead, or there is no
		# permission
		return $class->is_alive($pid) ? 0 : 1;
	}

	$class->wait_exit( $pid, $grace_period );

	# If the process is still alive, kill it with force
	if ( $class->is_alive($pid) ) {
		kill 'KILL', $pid;
		$class->wait_exit( $pid, 1 );

		# Final check
		return 0 if $class->is_alive($pid);
	}

	$on_kill->() if $on_kill;
	return 1;
}

# $class->_terminate_group($pid, %args):
#	The group form of terminate. Each signal goes to the process
#	group of $pid, with a negative pid on kill. The method returns
#	1 when no member answers kill 0 on the group. It returns 0
#	when a member still answers after the KILL.
#
#	The guard on $pid is a safety boundary. kill with the group id
#	0 signals the group of the caller, and kill with the group id
#	1 can reach far outside the caller. A bad $pid must therefore
#	signal nothing.
sub _terminate_group ( $class, $pid, %args )
{
	return 1 unless defined $pid && $pid =~ /^\d+$/ && $pid > 1;

	return 1 unless _group_alive($pid);

	my $grace_period = $args{grace_period} // 5;
	my $on_kill      = $args{on_kill};

	# Send SIGTERM to the whole group
	my $killed = kill 'TERM', -$pid;
	unless ($killed) {

		# Every member is already dead, or there is no
		# permission
		return _group_alive($pid) ? 0 : 1;
	}

	_wait_group_exit( $pid, $grace_period );

	# If a member is still alive, kill the group with force
	if ( _group_alive($pid) ) {
		kill 'KILL', -$pid;
		_wait_group_exit( $pid, 1 );

		# Final check
		return 0 if _group_alive($pid);
	}

	$on_kill->() if $on_kill;
	return 1;
}

# _group_alive($pid):
#	Report if a member of the process group of $pid still answers
#	kill 0. The check reaps each child member first, so a zombie
#	child of the caller does not count as a live member.
sub _group_alive ($pid)
{
	_reap_group($pid);

	return 1 if kill 0, -$pid;

	# A member can turn into a zombie between the reap above and
	# the check. Reap once more, so a zombie child never outlives
	# the answer "gone".
	_reap_group($pid);

	return 0;
}

# _reap_group($pid):
#	Reap each zombie child of the caller in the process group of
#	$pid. The leader comes first, by its own pid: the Darwin
#	kernel can detach a zombie from its process group, and the
#	group sweep below then misses it.
sub _reap_group ($pid)
{
	waitpid( $pid, WNOHANG );
	1 while waitpid( -$pid, WNOHANG ) > 0;

	return;
}

# _wait_group_exit($pid, $timeout):
#	Wait until no member of the process group of $pid answers, or
#	until the timeout ends. The method returns 1 when the group is
#	gone. It returns 0 on timeout.
sub _wait_group_exit ( $pid, $timeout )
{
	my $deadline = time + $timeout;
	while ( time < $deadline ) {
		return 1 unless _group_alive($pid);
		select undef, undef, undef, POLL_INTERVAL;
	}

	# Final check
	return _group_alive($pid) ? 0 : 1;
}

# $class->wait_exit($pid, $timeout):
#	Wait for the process to exit.
#	The method returns 1 if the process exits. It returns 0 on
#	timeout.
sub wait_exit ( $class, $pid, $timeout = 30 )
{
	my $deadline = time + $timeout;
	while ( time < $deadline ) {
		return 1 unless $class->is_alive($pid);
		select undef, undef, undef, POLL_INTERVAL;
	}

	# Final check
	return $class->is_alive($pid) ? 0 : 1;
}

# $class->spawn_perl(%args):
#	Spawn a Perl subprocess that inherits the parent's @INC paths.
#	This is a convenience wrapper around spawn_command() to run
#	Perl code.
#
#	%args:
#		code      => $string    # Required: the Perl code to execute
#		args      => \@args     # Optional: arguments for the code
#		The method passes all other args to spawn_command().
#
#	Example:
#		Fugu::Process->spawn_perl(
#			code => 'use MyModule; MyModule->run(@ARGV)',
#			args => [$port, $dir],
#			daemonize => 1,
#		);
sub spawn_perl ( $class, %args )
{
	my $code = delete $args{code}
	    or return { success => 0, error => 'No code specified' };
	my $extra_args = delete $args{args} // [];

	# Build the -I flags for all non-default @INC paths
	my @inc_flags = map { "-I$_" } _custom_inc_paths();

	$args{cmd} = [ $^X, @inc_flags, '-e', $code, @$extra_args ];

	return $class->spawn_command(%args);
}

# _fork_exec($cmd, $cwd, $env, $redirect):
#	The shared fork-and-exec step. Fork the child and run
#	$redirect in it to set up the standard handles; failures go
#	through _fail. Move the child into $cwd, and give it the
#	environment that $env names. Then exec the command over the
#	close-on-exec failure pipe. Return ($pid, undef) when the exec
#	resolved, or (undef, $error) when the machinery or the exec
#	failed - the child is already reaped in that case.
sub _fork_exec ( $cmd, $cwd, $env, $redirect )
{
	my ( $exec_r, $exec_w ) = _exec_pipe();
	return ( undef, "Cannot create pipe: $!" ) unless $exec_r;

	my $pid = fork;
	unless ( defined $pid ) {
		close $exec_r;
		close $exec_w;
		return ( undef, "Cannot fork: $!" );
	}

	if ( $pid == 0 ) {

		# Child process
		$DB::inhibit_exit = 0;
		close $exec_r;

		$redirect->($exec_w);
		_chdir_or_fail( $exec_w, $cwd );