This is a fairly robust forking server, put together from perlipc and this post in selfHTML (german)
#!/usr/bin/perl -w
+
use strict;
+
use IO::Socket;
+
use POSIX qw(:sys_wait_h);
+
use Errno;
+
+
my $waitedpid = 0;
+
my $terminated_pid = 0;
+
sub logmsg { print scalar localtime() . " $$: @_\n" }
sub REAPER {
local $!;
while (($waitedpid = waitpid(-1,WNOHANG)) > 0 && WIFEXITED($?)
+) {
$terminated_pid = $waitedpid;
+
logmsg "Parent: Reaped $waitedpid" . ($? ? " with exit
+ $?" : '');
}
$SIG{'CHLD'} = \&REAPER;
}
$SIG{'CHLD'} = \&REAPER;
my $sock = new IO::Socket::INET(
LocalHost => '127.0.0.1',
LocalPort => 9898,
Proto => 'tcp',
Listen => 10,
ReuseAddr => 1
);
$sock or die "no socket :$!";
logmsg "Parent $$: Server up";
STDERR->autoflush(1);
STDOUT->autoflush(1);
while (1) {
my $new_sock = $sock->accept() || do {
# try again if accept() returned because a signal was received
next if $!{EINTR};
die "accept: $!";
};
$new_sock->autoflush(1);
my($buf, $kid);
if ($kid = fork) {
# parent closes the client since
# it is not needed
logmsg "Parent after forking";
}
else {
die "fork: $!" unless defined $kid;
# child now...
logmsg "Child: started";
# read from client
$buf = <$new_sock>;
chomp $buf;
logmsg "Child: Read from client: $buf";
my $secs = int(rand(srand())*10)+1;
sleep $secs;
print $new_sock "READY\n";
logmsg "Child sent READY, closing";
$new_sock->close;
exit 0;
}
}
logmsg "Parent: Should never get here";
Regards,
svenXY