Richard Luckhurst wrote:
Hi List
Hello,
I have just been given the task of finding out why a perl sockets listener
application we have is no longer working correctly. The application was written
back in 2002 and I am told worked fine until we were forced to install a new
server early this year. I have no idea what version of perl the old server ran
but the new server is running 5.8.8.
perldoc perlhist
[ SNIP ]
5.6.0 2000-Mar-22
Sarathy 5.6.1-TRIAL1 2000-Dec-18 The 5.6 maintenance track.
5.6.1-TRIAL2 2001-Jan-31
5.6.1-TRIAL3 2001-Mar-19
5.6.1-foolish 2001-Apr-01 The "fools-gold" release.
5.6.1 2001-Apr-08
Rafael 5.6.2-RC1 2003-Nov-08
5.6.2 2003-Nov-15 Fix new build issues
It looks like probably version 5.6 or at least 5.005?
The change that would probably concern you is the change to safe signals
in Perl 5.8. Read the "Deferred Signals (Safe Signals)" section of:
perldoc perlipc
In fact, you should probably read through all of perlipc.
The idea of the listener is to start and sit and wait for a connection. When the
connection occurs a child listener should be created. The child shgould take
care of receiving data and sending it onto a posgres database. After an idle
timeout the child should exit.
What is happening is when the child exits it is killing the parent process as
well. I am told that this did not happen on the previous server and the parent
process would stay running until the server needed a reboot or the process was
manually killed.
I am not very familiar with perl so I am asking the list for any guidance as to
where the script may be failing.
I am including the code for the listener below.
#!/usr/bin/perl
use warnings;
use strict;
#
# Name: listener.pl
#
#
# Sub index:
# exCheckTrustedIP
# GetSock
# process_line
# ProcessRequests
# Reaper
# ServiceClients
# SetProperties
# StartDaemon
#
#
#-USE---------------------------------------------------------------------------
$debug = 1;
use IO::Socket;
use POSIX ":sys_wait_h"; # (for WNOHANG)
That should now be:
use POSIX 'WNOHANG';
use Fcntl;
#-CONSTANTS---------------------------------------------------------------------
my ($SERVER_ADDR, $SERVER_PORT, $LISTENER, $DATABASE_NAME, $DATABASE_PORT,
$DATABASE_HOST, $USER_ID, $PASSWORD, $DATABASE_LOCATION, $MESSAGE_TIMEOUT,
$IDLE_TIMEOUT,) = "";
That is the same as:
my $SERVER_ADDR = "":
my ($SERVER_PORT, $LISTENER, $DATABASE_NAME, $DATABASE_PORT,
$DATABASE_HOST, $USER_ID, $PASSWORD, $DATABASE_LOCATION,
$MESSAGE_TIMEOUT,
$IDLE_TIMEOUT,);
# Special cases are files and the associated database that they reside in.
# It is basically saying if you see this table name, regardles of the database you are
# meant to be talking to (eg hack, dev), talk to the database specified. Was introduced so that
# time records were always written to the "exodus' database.
# This could be moved at a later date to be read from an actual file.
# Note that the ip_access tables should also be in any database specified in the
# list.
# Format table_name => table_name,database_name,hostname,portname,user_id,password
%SPECIAL_CASES = '';
Hashes should be assigned key/value pairs. With warnings enabled that
would produce a warning message.
%SPECIAL_CASES =
But why the other assignment? You are just overwriting the ( '', undef
) pair that you previously assigned.
(
ex_time => "ex_time:exodus:203.xxx.xxx.x:5432:xxxxxx:xxxxxxx",
time_control =>
"time_control:exodus:203.xxx.xxx.x:5432:xxxxxx:xxxxxxx"
);
sub StartDaemon
{
print "Listener started\n";
SetProperties($_[0]);
my $pid;
if ($pid = fork()) {
waitpid($pid, 0);
} else {
If $pid is false it could be because either this is the child process or
because fork() failed. You are assuming that fork() was successful?
if ($pid = fork()) { exit; }
Why are you fork()ing again and exit()ing?
$0 = "$LISTENER: accepting connections on $SERVER_PORT"; # for ´ps´
ServiceClients( GetSock() ); # wait for incoming requests
}
}
#-------------------------------------------------------------------------------
# Changes:
# 13AUG03 DT Created sub.
sub SetProperties
{
my %properties = GetAllSiteRecordValues($_[0]); # eg. $_[0] = "hack"
$SERVER_ADDR = $properties{"listener.server.addr"}; # eg. 203.xxx.xxx.x
$SERVER_PORT = $properties{"listener.server.port"}; # eg. 15555
$DATABASE_NAME = $properties{"listener.db.name"}; # eg. hack
$DATABASE_PORT = $properties{"listener.db.port"}; # eg. 5432
$DATABASE_HOST = $properties{"listener.db.addr"}; # eg. 203.xxx.xxx.x
$USER_ID = $properties{"listener.db.user.id"}; # eg. beanman
$PASSWORD = $properties{"listener.db.user.password"};
$MESSAGE_TIMEOUT = $properties{"listener.timeout.message"}; # eg. 30 # Max
pause WITHIN a MESSAGE (seconds)
$IDLE_TIMEOUT = $properties{"listener.timeout.idle"}; # eg. 600 # Max
Pause BETWEEN messages (seconds)
$LISTENER = $DATABASE_NAME. "_listener";
$DATABASE_LOCATION =
"dbname=$DATABASE_NAME;host=$DATABASE_HOST;port=$DATABASE_PORT";
return 1;
}
#-------------------------------------------------------------------------------
sub GetSock {
# unlink $sockname;
my $sock = IO::Socket::INET->new(
LocalPort => $SERVER_PORT,
Type => SOCK_STREAM,
Reuse => 1,
Listen => 10,
) or die "$0: error starting $LISTENER daemon on '$SERVER_PORT':
[EMAIL PROTECTED]";
# you might want to change permissions and ownership, e.g.:
#chmod 0600, $sockname;
#chown scalar getpwnam('nobody'), 0, $sockname;
return $sock;
}
#-------------------------------------------------------------------------------
sub ServiceClients {
my $sock = shift;
$SIG{CHLD} = \&Reaper;
my $client;
while ( $client = $sock->accept() ) {
my $pid = fork(); die "Cannot fork\n" unless defined $pid;
if ($pid) { # parent
close $client; # no use to parent
next; # be ready for another client
}
# child
close $sock; # no use to child
ProcessRequests($client);
exit; # terminate child
}
}
#-------------------------------------------------------------------------------
sub ProcessRequests {
my $sock = shift;
my ($inline, $outline) = "";
That is the same as:
my $inline = "";
my $outline;
$| = 1; # don't buffer output - shouldn't need \n to print
Note that $| only applies to the currently selected filehandle. To
which filehandle did you want this to apply?
$0 = "$LISTENER: child handling requests..."; # for ´ps´
my $db_handle = &ex_open_pg_connection($DATABASE_LOCATION, $USER_ID,
$PASSWORD);
if (!$db_handle) {
exCloseWithError($sock, "Database error: Couldn't connect to database");
}
exCheckTrustedIP($db_handle, $sock);
# Set non-blocking IO (from O'Reilly Perl)
$flags = '';
fcntl($sock, F_GETFL, $flags) or die "Error: $!\n";
$flags |= O_NONBLOCK;
fcntl($sock, F_SETFL, $flags) or die "Error: $!\n";
# Read 8192 bytes at a time until hex 04 then start again
$buf = "";
$prev_message_time = time; # time last message was received.
$start_message_time = ''; # > null means partial message received
open (LOG, ">>/var/log/exodus/listener.log");
You should *always* verify that the file opened correctly:
open LOG, '>>', '/var/log/exodus/listener.log' or die "Cannot
open '/var/log/exodus/listener.log' $!";
while (1) {
# Check how long its been since last message received
# If more than "IDLE_TIMEOUT" seconds then exit (terminate child
process)
# Attempt to read data into buffer.
$i = recv $sock, $buf, 8192, '';
if (!$buf) {
# No data received - check for errors and timeouts.
if ($i < -1) {
exCloseWithError($sock, "Internal error: TCP Error. Read() returned:
$i");
}
# Check whether message receive in progress - if so check for
timeout.
$cur_time = time;
if ($start_message_time) {
if ($cur_time > $start_message_time + $MESSAGE_TIMEOUT) {
exCloseWithError($sock, "Message timeout ($MESSAGE_TIMEOUT)
seconds. Please retry.");
}
} else {
# no message currently being received - check for how long it's
been quiet...
if ($cur_time > $prev_message_time + $IDLE_TIMEOUT) {
exCloseWithError($sock, "A timeout has occurred after $IDLE_TIMEOUT
seconds of inactivity. >> Connection closed.");
}
}
}
else
{
# Some data received - check what we got.
if (($eom_idx = (index $buf, "\x04")) > -1)
{
# End_Of_Message received. Finalize bigbuf - should now be
entire message string
$end_buf = substr($buf, 0, $eom_idx);
$bigbuf .= $end_buf; # should now be in form
chklenRMidRMdata
$outline = exProcessMessage($db_handle, $sock, $bigbuf);
print LOG "OUT:$outline\n";
printf $sock $outline;
$prev_message_time = time;
$bigbuf = substr($buf, $eom_idx+1);
$buf = "";
$start_message_time = ''; # NO message currently being
received
} else {
$start_message_time = time;
$bigbuf .= $buf;
$buf = "";
}
}
}
close LOG;
&ex_close_pg_connection ($db_handle);
}
#-------------------------------------------------------------------------------
# Checks if IP address at other end of socket is trusted, if not send error
# message to socket and exit.
sub exCheckTrustedIP
{
my ($db_handle, $sock, $debug) = @_;
# Get client IP address
my $other_end = getpeername($sock)
or die "$LISTENER: Couldn't identify other end: $!\n";
my ($port, $iaddr) = unpack_sockaddr_in($other_end);
my $ip_address = inet_ntoa($iaddr);
# Confirm that client IP is trusted - if full IP not in table, test on
subnet
my $read_ptr = ex_read_pg_data ($db_handle, "", "trusted_ips", "EQ", $ip_address, "", "0",
"", "");
my $found_ip = shift (@$read_ptr);
if ($found_ip)
{
send $sock, "OK: Successfully connected to $SERVER_ADDR:$SERVER_PORT -
Hello, $ip_address\n", '';
}
else
{
# Test subnet - IP up to last . then 0 eg 203.113.254.0
my $ip_last_dot = rindex ($ip_address, ".");
my $subnet = substr($ip_address, 0, $ip_last_dot+1)."0";
Or alternately:
( my $subnet = $ip_address ) =~ s/[^.]+\z/0/;
my $read_ptr = ex_read_pg_data ($db_handle, "", "trusted_ips", "EQ", $subnet, "", "0",
"", "");
my $found_sub = shift (@$read_ptr);
if ($found_sub) { send $sock, "OK: Successfully connected to
$SERVER_ADDR:$SERVER_PORT - Hello, $ip_address on subnet $subnet", ''; }
else { printf $sock "ERROR: $ip_address is not a trusted IP
address. Please contact Exodus Systems Support if you believe this IP should be on our
Trusted IP list."; }
}
}
#-------------------------------------------------------------------------------
# Sends error message to client, then closes socket and exits
sub exCloseWithError
{
my ($sock, $err_msg, $debug) = @_;
if ($debug) { print "exCloseWithError:ERROR: $err_msg"; }
print $sock "ERROR: $err_msg";
close $sock;
exit(1);
}
#-------------------------------------------------------------------------------
# Processes a complete XML message string. Performs several checks for message
# validity, then sends message to Host and returns output to client before
# returning control to calling code
sub exProcessMessage
{
my ($db_handle, $sock, $message, $debug) = @_;
my ($file) = '';
# Check for first record mark
$rm1idx = index ($message, $RM);
if ($rm1idx == -1) {
print $sock "No Record mark in string - require 2";
return;
}
$chk_len = substr($message, 0, $rm1idx);
$msg = substr($message, $rm1idx+1);
$msg_len = length($msg);
if ($msg_len != $chk_len)
{
print $sock "Checksum doesn't match - ensure message length sent is correct: your
length>$chk_len< and message length>$msg_len<";
return;
}
@records = split(/$RM/, $msg);
$action = shift (@records);
my $file = lc $records[0];
^^
You are declaring $file a second time in the same scope. With warnings
enabled you would have received a warnings message about this.
if ($action eq "W")
{
if ($SPECIAL_CASES{$file}) {$outline = exWriteSpecialCases($sock, $db_handle, [EMAIL PROTECTED], $debug);}
else {$outline = exWriteToPG($db_handle, [EMAIL
PROTECTED], $debug); }
}
elsif ($action eq "M") { $outline = exProcessWebpayString([EMAIL
PROTECTED], $debug); }
else { $outline = "received action ->$action<-"; }
if ($debug) { Debug($outline, "outline", "", "", "connection response", "T",
"Y"); }
return $outline; #."\n"; # need \n for <socket> read to work...
}
#-------------------------------------------------------------------------------
sub Reaper {
while (waitpid(-1,WNOHANG) > 0) {}
That is usually written as:
1 while waitpid( -1, WNOHANG ) > 0;
$SIG{CHLD} = \&Reaper;
}
#-------------------------------------------------------------------------------
sub exWriteSpecialCases
{
my ($sock, $db_handle, $records_ptr, $debug) = @_;
my @records = @$records_ptr;
If you are just going to make a copy of @records then why not just make
@records the last argument and pass through the whole list instead of a
reference?
my $file = lc (shift (@records));
my $key = shift (@records);
my ( $file, $key, @records ) = @$records_ptr;
$file = lc $file;
my ($output) = "RESP:";
# @records should only have 1 element left now after having the first two
# shifted off
my @data = split (/\xFE/, $records[0]);
@data_location = split (/:/, $SPECIAL_CASES{$file});
my $DATABASE_LOCATION =
"dbname=$data_location[1];host=$data_location[2];port=$data_location[3]";
my $USER_ID = $data_location[4];
my $PASSWORD = $data_location[5];
my $db_handle = ex_open_pg_connection($DATABASE_LOCATION, $USER_ID, $PASSWORD);
^^
You are declaring $db_handle a second time in the same scope. With
warnings enabled you would have received a warnings message about this.
exCheckTrustedIP($db_handle, $sock);
$output .= &ex_write_pg_data($db_handle, "F", $file, $key, [EMAIL PROTECTED], $debug);
# close (DEBUG);
ex_close_pg_connection ($db_handle);
return $output;
}
#-------------------------------------------------------------------------------
1; #return true
Is this code being used as a module? If not then you don't need that
last line.
John
--
Perl isn't a toolbox, but a small machine shop where you
can special-order certain sorts of tools at low cost and
in short order. -- Larry Wall
--
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
http://learn.perl.org/
