view release on metacpan or  search on metacpan

t/fugu/process.t  view on Meta::CPAN

#!/usr/bin/env perl
# ex:ts=8 sw=4:
use v5.36;
use Test::More;
use FindBin qw($RealBin);
use lib "$RealBin/../../lib";

use Cwd        ();
use File::Temp qw(tempdir);
use Fugu::CLI  qw(EXIT_ERROR);

use_ok('Fugu::Process');

# Test 2: Basic spawn and terminate
{
	my $result = Fugu::Process->spawn_command(
		cmd => [ 'sleep', '300' ],
	);

	ok( $result->{success}, 'Spawned sleep process' );
	ok( defined $result->{pid}, 'Got PID' );
	my $pid = $result->{pid};

	ok( Fugu::Process->is_alive($pid), 'Process is alive' );

	my $killed = Fugu::Process->terminate( $pid, grace_period => 2 );
	ok( $killed, 'Terminated process' );

	ok( !Fugu::Process->is_alive($pid), 'Process is dead' );
}

# Test 3: a process that exits at once still spawned successfully.
# The exec resolved, so the spawn is a success; the caller that needs
# the outcome uses run.
{
	my $result = Fugu::Process->spawn_command(
		cmd => [ 'sh', '-c', 'exit 1' ],
	);

	ok( $result->{success}, 'A fast exit is still a successful spawn' );
	ok( defined $result->{pid}, 'and carries the PID' );
	Fugu::Process->wait_exit( $result->{pid}, 2 );
}

# Test 3c: An exec that fails reports its own reason at once, through
# the close-on-exec pipe and not through a wait-and-guess sleep.
{
	my $start  = time;
	my $result = Fugu::Process->spawn_command(
		cmd => ['/nonexistent/definitely-not-a-command'],
	);
	my $elapsed = time - $start;

	ok( !$result->{success}, 'An exec failure is a failure' );
	like(
		$result->{error},
		qr/Cannot exec .*definitely-not-a-command/,
		'the error names the command'
	);
	like( $result->{error}, qr/No such file|not found/i,
		'and carries the reason from the system' );
	ok( $elapsed <= 2, 'the report does not wait for a sleep' );
}

# Test 4: Invalid command
{
	my $result = Fugu::Process->spawn_command( cmd => [] );

	ok( !$result->{success}, 'Rejected empty command' );
	like( $result->{error}, qr/non-empty arrayref/, 'and says why' );

	my $scalar = Fugu::Process->spawn_command( cmd => 'sleep 1' );
	ok( !$scalar->{success}, 'Rejected a non-arrayref command' );
}

# Test 8: is_alive edge cases
{
	ok( !Fugu::Process->is_alive(undef),  'undef PID is not alive' );
	ok( !Fugu::Process->is_alive(''),     'Empty PID is not alive' );
	ok( !Fugu::Process->is_alive('abc'),  'Non-numeric PID is not alive' );
	ok( !Fugu::Process->is_alive(999999), 'Non-existent PID is not alive' );
	ok( Fugu::Process->is_alive($$),      'Own PID is alive' );
}

# Test 9: wait_exit
{
	my $result = Fugu::Process->spawn_command(
		cmd => [ 'sleep', '1' ],
	);

	my $exited = Fugu::Process->wait_exit( $result->{pid}, 5 );
	ok( $exited, 'Process exited within timeout' );
}

# Test 10: wait_exit timeout
{
	my $result = Fugu::Process->spawn_command(
		cmd => [ 'sleep', '10' ],
	);

	my $exited = Fugu::Process->wait_exit( $result->{pid}, 1 );
	ok( !$exited, 'Timeout waiting for exit' );

	Fugu::Process->terminate( $result->{pid} );
}

# Test 11: Graceful and forced termination
{
	# A process that ignores SIGTERM (sleep handles it)
	my $result = Fugu::Process->spawn_command(
		cmd => [ 'sleep', '300' ],
	);

	my $start  = time;
	my $killed = Fugu::Process->terminate( $result->{pid}, grace_period => 2 );
	my $elapsed = time - $start;

	ok( $killed, 'Process terminated' );
	ok( $elapsed < 5, 'Terminated quickly (graceful)' );
}

# Test 13: I/O redirection
{
	my $tmpdir  = tempdir( CLEANUP => 1 );
	my $outfile = "$tmpdir/fugu-process-test.txt";

	my $result = Fugu::Process->spawn_command(
		cmd    => [ 'echo', 'test output' ],
		stdout => $outfile,
	);

	sleep 1;
	Fugu::Process->wait_exit( $result->{pid}, 2 );

	ok( -f $outfile, 'Output file created' );
	if ( -f $outfile ) {
		open my $fh, '<', $outfile
		    or do { fail("Cannot read $outfile: $!"); };
		my $content = <$fh>;
		close $fh;
		like( $content, qr/test output/, 'Output redirected correctly' );
	}

t/fugu/process.t  view on Meta::CPAN

	# The default path of execvp(3) does not hold the temporary
	# directory, so the bare name fails without PATH.
	my $r = Fugu::Process->run(
		cmd => ['fugu-env-prog'],
		env => {},
	);
	ok( !$r->{success}, 'the bare name fails without PATH' );
	like( $r->{error}, qr/Cannot exec fugu-env-prog/,
		'and the error names the command' );

	$r = Fugu::Process->run(
		cmd => ['fugu-env-prog'],
		env => { PATH => $dir },
	);
	ok( $r->{success}, 'the same name succeeds with PATH in env' );
};

subtest 'a bad env returns an error and starts nothing' => sub {
	my @bad = (
		[ 'a value that is not a hashref' => 'not-a-hashref' ],
		[ 'an empty name'                 => { ''     => 'x' } ],
		[ 'an equals sign in a name'      => { 'A=B'  => 'x' } ],
		[ 'a NUL byte in a name'          => { "A\0B" => 'x' } ],
		[ 'an undefined value'            => { A      => undef } ],
		[ 'a reference value'             => { A      => [] } ],
		[ 'a NUL byte in a value'         => { A      => "x\0y" } ],
		[ 'a wide character in a name'    => { "\x{263a}" => 'x' } ],
		[ 'a wide character in a value'   => { A => "\x{263a}" } ],
	);

	for my $case (@bad) {
		my ( $name, $env ) = @$case;

		my $r = Fugu::Process->run(
			cmd => [ $^X, '-e', '1' ],
			env => $env,
		);
		ok( !$r->{success}, "run rejects $name" );
		ok( $r->{error},    'and says why' );

		my $s = Fugu::Process->spawn_command(
			cmd => [ $^X, '-e', '1' ],
			env => $env,
		);
		ok( !$s->{success},    "spawn_command rejects $name" );
		ok( !exists $s->{pid}, 'and starts nothing' );
	}

	my $r = Fugu::Process->run(
		cmd => [ $^X, '-e', '1' ],
		env => 'not-a-hashref',
	);
	is( $r->{exit_code}, EXIT_ERROR, 'the run shape: EXIT_ERROR' );
	is( $r->{stdout},    '',         'stdout is empty' );
	is( $r->{stderr},    '',         'stderr is empty' );
};

# _gone_soon($pid):
#	Poll until the process is dead, for up to five seconds. The
#	is_alive call reaps a zombie child of the test. A group member
#	that is not a child of the test waits for init to reap it, so
#	it can answer for a moment.
sub _gone_soon ($pid)
{
	for ( 1 .. 100 ) {
		return 1 unless Fugu::Process->is_alive($pid);
		select undef, undef, undef, 0.05;
	}

	return 0;
}

# _read_pids($file):
#	Poll until the file holds two pids, then return them. The
#	child writes the file directly after its fork, so the wait is
#	short.
sub _read_pids ($file)
{
	for ( 1 .. 100 ) {
		if ( open my $fh, '<', $file ) {
			my $content = do { local $/; <$fh> };
			close $fh;

			# The newline proves that the write is complete,
			# so a partial pid can never match.
			my @pids = $content =~ /^(\d+) (\d+)\n\z/;
			return @pids if @pids == 2;
		}
		select undef, undef, undef, 0.05;
	}

	return;
}

# The leader-and-grandchild program. It forks a grandchild that
# sleeps, writes both pids to the named file, and sleeps itself.
my $LEADER_CODE =
      'my $pid = fork; die "fork: $!" unless defined $pid; '
    . 'if ($pid == 0) { sleep 60; exit 0 } '
    . 'open my $fh, ">", $ARGV[0] or die "open: $!"; '
    . 'print {$fh} "$$ $pid\n"; close $fh; '
    . 'sleep 60';

subtest 'run with new_session makes the child a group leader' => sub {
	my $r = Fugu::Process->run(
		cmd         => [ $^X, '-e', 'print "$$ ", getpgrp(0)' ],
		new_session => 1,
	);
	ok( $r->{success}, 'the child runs' );
	my ( $pid, $pgid ) = split / /, $r->{stdout};
	is( $pgid, $pid, 'the group id of the child equals its pid' );
};

subtest 'run without new_session keeps the child in the caller group' =>
    sub {
	my $r = Fugu::Process->run(
		cmd => [ $^X, '-e', 'print getpgrp(0)' ],
	);
	ok( $r->{success}, 'the child runs' );
	is( $r->{stdout}, getpgrp(0), 'the child stays in the group' );
    };

subtest 'run with new_session and a timeout stops the whole group' => sub {
	my $dir  = tempdir( CLEANUP => 1 );
	my $file = "$dir/pids.txt";