Whirlpool

Hi,

The below script is inside a foreach loop. The first loop works fine. It sleeps for 5 seconds. There after it doesnt work at all!

1. Create child
   $proc = Proc::Simple->new();

$proc->start($target, $file);
$proc->start( sub { sleep(5) } );

$proc->kill();

I've even tried using select() with a timeout set to make it sleep. Same problem occurs.

As you can see above the Proc::Simple module is being used above. Without it:
my $pid = fork();

if (not defined $pid)
{
print "[!] out of resources!";
}

if (!$pid)
{
system($cmd);
sleep(5);
}

kill("TERM" => $pid); # SendSIGTERM to child

Same problem.

yadadamean writes...

There after it doesnt work at all!

Given that you're not doing anything after the sleep, how can you possibly tell?

Almost every line in these examples is wrong.

I wouldn't use the same Proc::Simple object for two processes, since then you have no easy way to poll or wait on the two processes individually. You're not checking the return values of the start calls. And why on Earth are you immediately killing the process? (Presumably the second one, that is, since you reused the object...)

In your explicit fork example, you'll want to die if the fork fails, not just print out an error (which, unless you've turned on autoflushing, will hang around in the STDOUT output buffer anyway, since there's no newline in the string). Also you'll want to make sure the child process exits, and doesn't continue on with the stuff the parent's doing as well.

Also note that the way you're using kill is racy — there's no guarantee that the child process has called system by the time its killed. Again, I have no idea why you want to kill the child immediately...

It looks like you're trying to do something very simple in a very complicated manner.

hrm ok. I'll play around with it later, after work.

What i'm wanting to do is execute a process, then allow the process to run for 5 seconds, then kill it.

yadadamean writes...

What i'm wanting to do is execute a process, then allow the process to run for 5 seconds, then kill it.

If the process doesn't have a SIGALRM handler (which is the case for most software), it's usually easiest just to set up an alarm.

There are good ways to do this, and bad ways. The "simplest" is to simply fork, set up the alarm and exec the process, and have the parent wait for the child to exit:

my $pid = fork;
defined $pid
	or die "Could not fork: $!\n";
unless ($pid) {
	local $SIG{ALRM} = 'DEFAULT';
	alarm $timeout;

	exec $program, @args
		or die "Could not execute $program: $!\n";
}

waitpid $pid, 0;

However there's a couple of problems with this. First, imagine $program was not executable. exec will fail, the child process will die, but the parent won't know why it died. It simply doesn't have access to the error condition detected by the child.

Another problem is the way exec may use the shell. Specifically, if @args is empty and $program contains shell meta-characters, then Perl actually does something like this (on Unixish systems, at least — I don't know what it does on Windows):

exec { $program } '/bin/sh', '-c', $program;

This time if the program could not be run for some reason, not even the child process will be able to work out why — the reason is gobbled up by the shell.

We can force Perl to never use the shell by using that indirect object notation:

exec { $program } $program, @args;

but that still doesn't help with the first problem. And anyway, sometimes its useful to be able to use the shell, such as when you want to call out to another program but redirect its input from a file.

The system builtin gets around these problem by constructing a status pipe between the parent and child, then using this pipe to propagate back an error code if the exec fails. But since we're implementing our own special kind of system, we need to reimplement this in Perl.

There is a Proc::SyncExec module to help with this kind of stuff, but I've found that it never quite meets the requirements I have, so I usually do it all manually:

use Errno qw(EINTR);
use IO::Pipe;
use POSIX qw(:sys_wait_h F_SETFD FD_CLOEXEC);

sub alarmed_system {
	my ($timeout, $program, @args) = @_;

	my $pipe = new IO::Pipe
		or die "Could not create pipe: $!\n";

	my $pid = fork;
	defined $pid
		or die "Could not fork: $!\n";
	unless ($pid) {
		# Child
		$pipe->writer;

		local $SIG{ALRM} = 'DEFAULT';
		alarm $timeout;

		local $^W;
		unless (
			$pipe->fcntl(F_SETFD, FD_CLOEXEC) and
			exec $program, @args
		) {
			$pipe->syswrite(0 + $!);
			POSIX::_exit 1;
		};
	}

	# Parent
	$pipe->reader;

	my $buf = "";
	while (1) {
		my $read = $pipe->sysread($buf, 16, length $buf);
		unless (defined $read) {
			next if $! == EINTR;
			die "Could not read from status pipe: $!\n";
		}
		last unless $read;
	}

	my $err = length $buf ? (0 + $buf) : 0;
	waitpid $pid, 0;

	if (length $buf) {
		$! = 0 + $buf;
		$? = -1;
	}

	$?;
}

This sub should have pretty much the same behaviour as the system builtin (ie, it uses, or doesn't use, the shell in the same way system would), except that it takes an extra initial argument specifying a timeout.

Like system, you should check the various values of $? after calling it.

alarmed_system $timeout, $program, @args;
if ($? == -1) {
	die "Could not execute $program: $!\n";
} elsif (WIFSIGNALED($?)) {
	my $sig = WTERMSIG($?);
	# Optionally handle $sig == POSIX::SIGCHLD differently here
	die "Child died with signal $sig\n";
} elsif (my $status = WEXITSTATUS($?)) {
	die "Child exited with status ", WEXITSTATUS($?), "\n";
}

Note that all of this is dependent on the program you're calling not setting up its own SIGALRM handler. If it does, then you probably do need to go the route of sending TERM and (if necessary) KILL signals. But let's not take that route unless it's absolutely necessary.

Writing "reliable" software is really annoying, sometimes...

Just been reading perlport, and if you're targeting Windows only, the "simplest" solution at the top of this post should be quite sufficient. (In fact, the big one further down won't even work, since Perl on Windows does not implement fcntl).

You'll probably want to check perlport and perlfork yourself to be sure.