E
Eric Frazier
Hi,
I am pretty desparate to get this working, and if anyone wants to earn
some cash helping me fix things PLEASE call me at 250 655-9513.
Thanks to a guy on comp.lang.perl.misc I know that there is a change in
how signals are handled, they call it deferred signal handling because
Perl now is suppose to wait until the Interpeter is in a safe state. As
I understand it this might avoid some things like core dumps or other
errors related to dieing while trying to do something besides dieing.
The thing is somehow this ends up killing off my parent process, just
like in this post:
http://www.mail-archive.com/[email protected]/msg43989.html
So this is happening to me as well, however the guy in the above example
had his problem solved by using Errno and looking for EINTR if that
error is raised then catch it and move on. This isn't working for me, or
else I don't know how to use the advice I was given about it.
I did get one maybe helpfull thing from my log:
Erro was %! --------
../franken_socket.pl 8607: got - CHLD
at Tue Sep 16 02:17:42 2003
I got forked
../franken_socket.pl 8599: begat 8607 at Tue Sep 16 02:17:40 2003
begat 8607
../franken_socket.pl 8599: got - CHLD
at Tue Sep 16 02:17:54 2003
../franken_socket.pl 8599: main 8607 -- reaped 1 at Tue Sep 16 02:17:54
2003
reaped 1Erro was No child processes %! --------
So it looks like the parent got killed on that error "No child process"
This code works just fine on 5.6 since it is about 150% from examples
The above is the result of connecting, doing a "who", and doing "dienow"
to test the alarm.
I also found this:
http://archive.develooper.com/[email protected]/msg03022.html
Which totaly describes my problem as well, but shows it happening with
perl 5.8.1..
#!/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;
};
print DIED "Erro was $! %! --------\n";
$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; }
elsif (/who/i ) { print $connection `who
2>&1`;}
elsif (/dienow/i ) { alarm 2; }
elsif (/dieT/i ) {
die; }
#REAPER_NEW($pid) if $return_value;
print $connection "Command?";
print DIED "I got forked\n";
}
exit(0);
#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..
} ## end while <$connection>
} ## end else
close ($listen_socket);
I am pretty desparate to get this working, and if anyone wants to earn
some cash helping me fix things PLEASE call me at 250 655-9513.
Thanks to a guy on comp.lang.perl.misc I know that there is a change in
how signals are handled, they call it deferred signal handling because
Perl now is suppose to wait until the Interpeter is in a safe state. As
I understand it this might avoid some things like core dumps or other
errors related to dieing while trying to do something besides dieing.
The thing is somehow this ends up killing off my parent process, just
like in this post:
http://www.mail-archive.com/[email protected]/msg43989.html
So this is happening to me as well, however the guy in the above example
had his problem solved by using Errno and looking for EINTR if that
error is raised then catch it and move on. This isn't working for me, or
else I don't know how to use the advice I was given about it.
I did get one maybe helpfull thing from my log:
Erro was %! --------
../franken_socket.pl 8607: got - CHLD
at Tue Sep 16 02:17:42 2003
I got forked
../franken_socket.pl 8599: begat 8607 at Tue Sep 16 02:17:40 2003
begat 8607
../franken_socket.pl 8599: got - CHLD
at Tue Sep 16 02:17:54 2003
../franken_socket.pl 8599: main 8607 -- reaped 1 at Tue Sep 16 02:17:54
2003
reaped 1Erro was No child processes %! --------
So it looks like the parent got killed on that error "No child process"
This code works just fine on 5.6 since it is about 150% from examples
The above is the result of connecting, doing a "who", and doing "dienow"
to test the alarm.
I also found this:
http://archive.develooper.com/[email protected]/msg03022.html
Which totaly describes my problem as well, but shows it happening with
perl 5.8.1..
I'd imagine that your accept() isn't being restarted. How does it work
if you change the loop to look like this?
use Errno;
while (1) {
my $client = $server->accept or do {
next if $!{EINTR};
last;
};
spawn(\&function, "whatever");
}
#!/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;
};
print DIED "Erro was $! %! --------\n";
$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; }
elsif (/who/i ) { print $connection `who
2>&1`;}
elsif (/dienow/i ) { alarm 2; }
elsif (/dieT/i ) {
die; }
#REAPER_NEW($pid) if $return_value;
print $connection "Command?";
print DIED "I got forked\n";
}
exit(0);
#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..
} ## end while <$connection>
} ## end else
close ($listen_socket);