Tring to kill my kids, but they are stuborn little bastards!

[Eric Frazier]

Hi,

I have finaly got my server running, but I am having a problem with
killing off my forked processes.
I am kind of stuck, because I could swear this was working before, and
now it is not.
I am running on perl 5.8 with FreeBSD 4.8. Other than this problem, it
is doing just what I want, forking off right away, and then giving the
command prompt.

Below is what I have now..

I have seen a few differnet ways of killing off children, but if the
SIGCHLD isn't getting called for some
reason I don't know if fiddling with the handler will help.. Right now I
am not getting any messages from the child handler, and every connect
makes a new process. This is sucking alot since otherwise life seems
great. The alarm and HUP work fine.

Thanks,

Eric


use strict;
use POSIX ();
use IO::Socket;
use FindBin ();
use File::Basename ();
use File::Spec::Functions;
use Net::hostent;
use Carp;

$|=1;

open (DIED, ">>/var/log/daemon_log") or warn "$!";
sub logmsg { print DIED "$0 $$: @_ at ", scalar localtime, "\n" }

my $listen_socket = IO::Socket::INET->new(LocalPort => 1081,
LocalAddr => '127.0.0.1',
Proto => 'tcp',
Listen => SOMAXCONN,
Reuse => 1 )
or die "can make a tcp server on port 1080 $!";


# make the daemon cross-platform, so exec always calls the script
# itself with the right path, no matter how the script was invoked.
my $script = File::Basename::basename($0);
my $SELF = catfile $FindBin::Bin, $script;
# POSIX unmasks the sigprocmask properly
my $sigset = POSIX::SigSet->new();
my $action = POSIX::SigAction->new('sigHUP_handler',
$sigset,
&POSIX::SA_NODEFER);
my $action_alrm = POSIX::SigAction->new('sigALRM_handler',
$sigset,
&POSIX::SA_NODEFER);

POSIX::sigaction(&POSIX::SIGHUP, $action);
POSIX::sigaction(&POSIX::SIGALRM, $action_alrm);

sub sigHUP_handler {
print "got SIGHUP\n";
exec($SELF, @ARGV) or die "Couldn't restart: $!\n";
}
sub sigALRM_handler {
print "got ALARM timeout\n";

}

$SIG{CHLD} = \&REAPER;

sub REAPER {
#$SIG{CHLD} = \&REAPER; # loathe sysV
my $waitedpid = wait;
logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
}


print "PID: $$\n";
print "ARGV: @ARGV\n";
print "[Server $0 accepting clients]\n";

while (my $connection = $listen_socket->accept()) {

my $pid;
if (!defined($pid = fork)) {
logmsg "cannot fork: $!";

}elsif ($pid) {
logmsg "begat $pid";
}else{
# else i'm the child -- go spawn
print $connection "Command?";
while ( <$connection> ){

if (/quit|exit/i) {
last; }
elsif (/closeme/i )
{$connection->close(); }
elsif (/date|time/i) { printf $connection "%s\n",
scalar localtime; }
elsif (/who/i ) { print $connection `who
2>&1`; }
elsif (/dienow/i ) { alarm
2; }
elsif (/dieT/i ) {
die; }

print $connection "Command?";
}




#STDIN->fdopen($connection,"r") || die "can't dup client to
stdin";
#STDOUT->fdopen($connection,"w") || die "can't dup client to
stdout";
#STDERR->fdopen($connection,"w") || die "can't dup stdout to
stderr";

### FORKed code here..
print DIED "I got forked\n";
} ## end while <$connection>

} ## end else

[Steve Grazzini]

Eric Frazier <eric@dmcontact.com> wrote:

> I am running on perl 5.8
>
> $SIG{CHLD} = \&REAPER;
>
> while (my $connection = $listen_socket->accept()) {

The "deferred signal" system introduced in 5.8.0 doesn't use SA_RESTART
when installing %SIG handlers (and you didn't use it with sigaction()
in the bit I snipped). This means that the accept() syscall will fail
when it's interrupted by any of those handled signals.

I'm not sure whether this matches the symptoms you were trying to describe,
since the result will be that the parent exits after the first signal
arrives, but it's certainly something to consider. The simplest solution
is to rewrite the loop with an extra test for EINTR.

use Errno;

while (1) {
my $con = $sock->accept() or do {
next if $!{EINTR};
last;
};
}

--
Steve

[Eric Frazier]

Hi,

The parent is not getting killed. At least I am pretty sure it is not.
I will do some reading, I don't know about EINTR at all.

What I see happening is that I start the server, I telnet to it and run
a command, exit with quit.
then do a ps and see 2 perl processes, both look the same, neither has
the (perl) which I thought ment that it was a child. If I do this same
process of connect/exit connect/exit I will build up more and more of
these processes.

root 5356 0.0 0.6 7232 6704 p3 I 9:27AM 0:00.21
/usr/bin/perl -w ./franken_socket.pl
root 5364 0.0 0.6 7360 6716 p3 I 9:27AM 0:00.01
/usr/bin/perl -w ./franken_socket.pl
root 5369 0.0 0.6 7296 6712 p3 I 9:27AM 0:00.00
/usr/bin/perl -w ./franken_socket.pl

The above results from starting the server and connecting twice.

I also may be getting a little confused because I did do some of this
work on a machine with 5.6 and I know there have been a lot of changes.


Thank you for your response.

Eric

Steve Grazzini wrote:

>
> Eric Frazier <eric@dmcontact.com> wrote:

> > I am running on perl 5.8
> >
> > $SIG{CHLD} = \&REAPER;
> >
> > while (my $connection = $listen_socket->accept()) {

>
> The "deferred signal" system introduced in 5.8.0 doesn't use SA_RESTART
> when installing %SIG handlers (and you didn't use it with sigaction()
> in the bit I snipped). This means that the accept() syscall will fail
> when it's interrupted by any of those handled signals.
>
> I'm not sure whether this matches the symptoms you were trying to describe,
> since the result will be that the parent exits after the first signal
> arrives, but it's certainly something to consider. The simplest solution
> is to rewrite the loop with an extra test for EINTR.
>
> use Errno;
>
> while (1) {
> my $con = $sock->accept() or do {
> next if $!{EINTR};
> last;
> };
> }
>
> --
> Steve

[Heinrich Mislik]

In article <3F64B2EB.3E7E39CA@dmcontact.com>, [email]eric@dmcontact.com[/email] says...

I didn' test this, but please consider the following:

[code snipped]

>while (my $connection = $listen_socket->accept()) {
>
> my $pid;
> if (!defined($pid = fork)) {
> logmsg "cannot fork: $!";
>
> }elsif ($pid) {
> logmsg "begat $pid";
> }else{
> # else i'm the child -- go spawn
> print $connection "Command?";
> while ( <$connection> ){
>
> if (/quit|exit/i) {
>last; }

This gets the child out of the 'while ( <$connection> )' loop, but leaves it in the 'while (my $connection = $listen_socket->accept())' loop. So the child never dies, but listens for new connections.
Entering the command dieT at your prompt should really kill the child.

> elsif (/closeme/i )
>{$connection->close(); }
> elsif (/date|time/i) { printf $connection "%s\n",
>scalar localtime; }
> elsif (/who/i ) { print $connection `who
>2>&1`; }
> elsif (/dienow/i ) { alarm
>2; }
> elsif (/dieT/i ) {
>die; }

dieT is a typo, isn't it.

hth.

--
Heinrich Mislik
Zentraler Informatikdienst der Universitaet Wien
A-1010 Wien, Universitaetsstrasse 7
Tel.: (+43 1) 4277-14056, Fax: (+43 1) 4277-9140

[bob]

Hi,

You know you really kind of hit the nail on the head. The exit or die,
don't kill the child. I do want to be able to have the child accept a
command though, so other than not dieing when it is done, it is doing
what I want.

Thanks for your post,

Eric

Heinrich Mislik wrote:

> In article <3F64B2EB.3E7E39CA@dmcontact.com>, [email]eric@dmcontact.com[/email] says...
>
> I didn' test this, but please consider the following:
>
> [code snipped]
>
>

>>while (my $connection = $listen_socket->accept()) {
>>
>> my $pid;
>> if (!defined($pid = fork)) {
>> logmsg "cannot fork: $!";
>>
>> }elsif ($pid) {
>> logmsg "begat $pid";
>> }else{
>> # else i'm the child -- go spawn
>> print $connection "Command?";
>> while ( <$connection> ){
>>
>> if (/quit|exit/i) {
>>last; }

>
>
> This gets the child out of the 'while ( <$connection> )' loop, but leaves it in the 'while (my $connection = $listen_socket->accept())' loop. So the child never dies, but listens for new connections.
> Entering the command dieT at your prompt should really kill the child.
>
>
>

>> elsif (/closeme/i )
>>{$connection->close(); }
>> elsif (/date|time/i) { printf $connection "%s\n",
>>scalar localtime; }
>> elsif (/who/i ) { print $connection `who
>>2>&1`; }
>> elsif (/dienow/i ) { alarm
>>2; }
>> elsif (/dieT/i ) {
>>die; }

>
>
> dieT is a typo, isn't it.
>
> hth.
>

[bob]

Hi,

This is another example I did = cut from examples.

This one, works, but when I exit the whole thing including the parent die!

#!/usr/bin/perl -w

use strict;
use POSIX ();
use POSIX 'WNOHANG';
#use POSIX ":sys_wait_h";
use FindBin ();
use File::Basename ();
use File::Spec::Functions;
use Net::hostent;
use Carp;
use Data::Dumper;
use Asiadebit;

$|=1;
sub spawn; # forward declaration
sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }


#use IO::Socket::INET;
use IO::Socket;


my $listen_socket = IO::Socket::INET->new(LocalPort => 1081,
LocalAddr => '127.0.0.1',
Proto => 'tcp',
Listen => SOMAXCONN,
Reuse => 1 )
or die "can make a tcp server on port 1080 $!";


# make the daemon cross-platform, so exec always calls the script
# itself with the right path, no matter how the script was invoked.
my $script = File::Basename::basename($0);
my $SELF = catfile $FindBin::Bin, $script;
# POSIX unmasks the sigprocmask properly
my $sigset = POSIX::SigSet->new();
my $action = POSIX::SigAction->new('sigHUP_handler',
$sigset,
&POSIX::SA_NODEFER);
my $action_alrm = POSIX::SigAction->new('sigALRM_handler',
$sigset,
&POSIX::SA_NODEFER);


POSIX::sigaction(&POSIX::SIGHUP, $action);
POSIX::sigaction(&POSIX::SIGALRM, $action_alrm);

sub sigHUP_handler {
print "got SIGHUP\n";
exec($SELF, @ARGV) or die "Couldn't restart: $!\n";
}
sub sigALRM_handler {
print "got ALARM timeout\n";

}

$SIG{CHLD} = \&REAPER_NEW;

sub REAPER {
$SIG{CHLD} = \&REAPER; # loathe sysV
my $waitedpid = wait;
logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
}

sub REAPER_NEW {
logmsg "got - @_\n";
my $wpid = undef;
while ($wpid = waitpid(-1,WNOHANG)>0) {

logmsg "reaped $wpid" . ($? ? " with exit $?" : '');

}



}




code();



sub code {
print "PID: $$\n";
print "ARGV: @ARGV\n";
open (DIED, ">>/var/log/daemon_log") or warn "$!";


my $c = 0;
#while (++$c) {
# sleep 2;
# my $bob = `w`;
# print DIED "$bob\n";

#print "$c\n";
#}
print "[Server $0 accepting clients]\n";
while (my $connection = $listen_socket->accept()) {
$connection->autoflush(1);
print $connection "Welcome to $0; type help for command list.\n";
my $hostinfo = gethostbyaddr($connection->peeraddr);
printf "[Connect from %s]\n", $hostinfo->name || $connection->peerhost;
print $connection "Command? ";



spawn sub {

while ( <$client>) {
next unless /\S/; # blank line
if (/quit|exit/i) { last; }
elsif (/date|time/i) { printf $connection "%s\n", scalar
localtime; }
elsif (/who/i ) { print $connection `who 2>&1`;
}
elsif (/dienow/i ) { alarm 2; }
elsif (/dieT/i ) { die; }
elsif (/spawnme/i ) { spawn \&code(); }
elsif (/cleanme/i ) { REAPER(); }
elsif (/debug/i ) { print Dumper($client);}
elsif (/spawn/i) {

spawn sub {

sleep 1;

print "Hello there, it's now ", scalar localtime, "\n";

sleep 3;

print "EXITING\n";
#exec '/usr/games/fortune'
# or confess "can't exec fortune: $!";
};

}
elsif (/alarmtest/i) { test_alarm(); }
elsif (/motd/i ) { print $client `cat /etc/motd 2>&1`; }
elsif (/AUTH/i ) { print do_auth($_) }
else {
print $client "Commands: quit date who cookie motd\n";
print DIED "Commands: quit date who cookie motd\n";
}


### print the prompt again regardless of input...
print $connection "Command? ";
}
close $connection;
} ## end 2nd while

} ### end code sub

} ## end 1st while

sub test_alarm {


alarm 5;

while (1>0){
sleep 1;
print "$_ to go";

}



}

sub spawn {

my $coderef = shift;


#local $SIG{CHLD} = \&REAPER;

#sub REAPER {
# $SIG{CHLD} = \&REAPER; # loathe sysV
# my $waitedpid = wait;
# logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
#}

unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
confess "usage: spawn CODEREF";
}
my $pid;
if (!defined($pid = fork)) {
logmsg "cannot fork: $!";
return;
} elsif ($pid) {
logmsg "begat $pid";
return; # i'm the parent
}
# else i'm the child -- go spawn
#open(STDIN, "<$client") || die "can't dup client to stdin";
#open(STDOUT, ">$client") || die "can't dup client to stdout";
#open(STDERR, ">&STDOUT") || die "can't dup stdout to stderr";


#### Works but we need the connected socket object!!!!
#STDIN->fdopen($client,"r") || die "can't dup client to stdin";
#STDOUT->fdopen($client,"w") || die "can't dup client to stdout";
#STDERR->fdopen($client,"w") || die "can't dup stdout to stderr";



exit &$coderef();



}



Heinrich Mislik wrote:

> In article <3F64B2EB.3E7E39CA@dmcontact.com>, [email]eric@dmcontact.com[/email] says...
>
> I didn' test this, but please consider the following:
>
> [code snipped]
>
>

>>while (my $connection = $listen_socket->accept()) {
>>
>> my $pid;
>> if (!defined($pid = fork)) {
>> logmsg "cannot fork: $!";
>>
>> }elsif ($pid) {
>> logmsg "begat $pid";
>> }else{
>> # else i'm the child -- go spawn
>> print $connection "Command?";
>> while ( <$connection> ){
>>
>> if (/quit|exit/i) {
>>last; }

>
>
> This gets the child out of the 'while ( <$connection> )' loop, but leaves it in the 'while (my $connection = $listen_socket->accept())' loop. So the child never dies, but listens for new connections.
> Entering the command dieT at your prompt should really kill the child.
>
>
>

>> elsif (/closeme/i )
>>{$connection->close(); }
>> elsif (/date|time/i) { printf $connection "%s\n",
>>scalar localtime; }
>> elsif (/who/i ) { print $connection `who
>>2>&1`; }
>> elsif (/dienow/i ) { alarm
>>2; }
>> elsif (/dieT/i ) {
>>die; }

>
>
> dieT is a typo, isn't it.
>
> hth.
>

[Steve Grazzini]

bob <eric@dmcontact.com> wrote:

> This one, works, but when I exit the whole thing including the
> parent die!
> $SIG{CHLD} = \&REAPER_NEW;
>
> while (my $connection = $listen_socket->accept()) {

I already told you why this is happening.

When the child exits, SIGCHLD will interrupt the accept() system
call. Perl 5.8 installs %SIG handlers without SA_RESTART, and so
accept() fails when interrupted. (And then the parent falls out
of its loop and exits.)

--
Steve

[bob]

Hi,

I think I see that happening, and know you are right, but this doesn't
seem to matter.

#while (my $connection = $listen_socket->accept()) {
while (1) {
my $connection = $listen_socket->accept() or do {
next if $!{EINTR};
last;
};


Sorry if I am being clueless, but I have done a lot of reading and
working at this, but I seem to keep getting it wrong.

Here is a sample run, with what I write to my log file:

secure# ./franken_socket.pl &
[1] 7186
secure# PID: 7186
ARGV:
[Server ./franken_socket.pl accepting clients]

secure# telnet localhost 1081
Trying 127.0.0.1...
Connected to localhost.
Escape character is '^]'.
Command?who
root ttyp0 Sep 11 10:51 (24.68.221.164)
root ttyp1 Sep 11 10:52 (24.68.221.164)
root ttyp2 Sep 11 11:23 (24.68.221.164)
Command?quit
Connection closed by foreign host.
[1] + Done ./franken_socket.pl


Log file cotains:

../franken_socket.pl 7194: got - CHLD
at Mon Sep 15 05:49:55 2003
I got forked
../franken_socket.pl 7186: begat 7194 at Mon Sep 15 05:49:54 2003
begat 7194
../franken_socket.pl 7186: got - CHLD
at Mon Sep 15 05:49:58 2003
../franken_socket.pl 7186: main 7194 -- reaped 1 at Mon Sep 15 05:49:58 2003
reaped 1



This is what I am running above:

#!/usr/bin/perl -w

## new frankenstein!

use strict;
use POSIX ();
use POSIX 'WNOHANG';
use Errno;
use IO::Socket;
use FindBin ();
use File::Basename ();
use File::Spec::Functions;
use Net::hostent;
use Carp;


$|=1;
my $pid;

open (DIED, ">>/var/log/daemon_log") or warn "$!";
sub logmsg { print DIED "$0 $$: @_ at ", scalar localtime, "\n" }

my $listen_socket = IO::Socket::INET->new(LocalPort => 1081,
LocalAddr => '127.0.0.1',
Proto => 'tcp',
Listen => SOMAXCONN,
Reuse => 1 )
or die "can make a tcp server on port 1080 $!";


# make the daemon cross-platform, so exec always calls the script
# itself with the right path, no matter how the script was invoked.
my $script = File::Basename::basename($0);
my $SELF = catfile $FindBin::Bin, $script;
# POSIX unmasks the sigprocmask properly
my $sigset = POSIX::SigSet->new();
my $action = POSIX::SigAction->new('sigHUP_handler',
$sigset,
&POSIX::SA_NODEFER);
my $action_alrm = POSIX::SigAction->new('sigALRM_handler',
$sigset,
&POSIX::SA_NODEFER);


POSIX::sigaction(&POSIX::SIGHUP, $action);
POSIX::sigaction(&POSIX::SIGALRM, $action_alrm);

sub sigHUP_handler {
print "got SIGHUP\n";
exec($SELF, @ARGV) or die "Couldn't restart: $!\n";
}
sub sigALRM_handler {
print "got ALARM timeout\n";

}

$SIG{CHLD} = \&REAPER_NEW;

sub REAPER {
$SIG{CHLD} = \&REAPER; # loathe sysV
my $waitedpid = wait;
logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
}

sub REAPER_NEW {
logmsg "got - @_\n";
my $wpid = undef;
while ($wpid = waitpid(-1,WNOHANG)>0) {

logmsg "main $pid -- reaped $wpid" . ($? ? " with exit $?" :
'');
print DIED "reaped $wpid" . ($? ? " with exit $?" : '');

}
}


print "PID: $$\n";
print "ARGV: @ARGV\n";
print "[Server $0 accepting clients]\n";

#while (my $connection = $listen_socket->accept()) {
while (1) {
my $connection = $listen_socket->accept() or do {
next if $!{EINTR};
last;
};

$connection->autoflush(1); ## missing seemed to cause client
problem, but not telnet

if (!defined($pid = fork)) {
logmsg "cannot fork: $!";

}elsif ($pid) {
logmsg "begat $pid";
print DIED "begat $pid\n";
}else{
# else i'm the child -- go spawn
print $connection "Command?";

while ( <$connection> ){

my $return_value = undef;

if (/quit|exit/i) { last; }
elsif (/closeme/i ) {$connection->close(); }
elsif (/date|time/i) { printf $connection "%s\n", scalar
localtime; exit(0); }
elsif (/who/i ) { print $connection `who 2>&1`;}
elsif (/dienow/i ) { alarm 2; exit(0); }
elsif (/dieT/i ) { die; }

print $connection "Command?";

print DIED "I got forked\n"; }
exit(0);


} ## end while <$connection>

} ## end else

close ($listen_socket);



Steve Grazzini wrote:

> bob <eric@dmcontact.com> wrote:
>

>>This one, works, but when I exit the whole thing including the
>>parent die!
>> $SIG{CHLD} = \&REAPER_NEW;
>>
>> while (my $connection = $listen_socket->accept()) {

>
>
> I already told you why this is happening.
>
> When the child exits, SIGCHLD will interrupt the accept() system
> call. Perl 5.8 installs %SIG handlers without SA_RESTART, and so
> accept() fails when interrupted. (And then the parent falls out
> of its loop and exits.)
>

[bob]

Hi,

I just wanted to confirm, this exact code does work prefectly in Perl
5.6. So Steve, you are certainly correct. I just don't know how to fix
it in 5.8.

Thanks,

Eric

bob wrote:

> Hi,
>
> I think I see that happening, and know you are right, but this doesn't
> seem to matter.
>
> #while (my $connection = $listen_socket->accept()) {
> while (1) {
> my $connection = $listen_socket->accept() or do {
> next if $!{EINTR};
> last;
> };