Re: Perl Sockets Communications

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': $@\n";
# 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, \@records, $debug);}
else {$outline = exWriteToPG($db_handle, \@records, $debug); }
}
elsif ($action eq "M") { $outline = exProcessWebpayString(\@records, $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, \@data, $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

.

Relevant Pages

  • Need help with a simple UNIX sockets server based on IO::Socket::UNIX
    ... I've tried to create a simple client + server that communicate ... alternate client connection with error "No child processes". ... + server code below for those who are interrested in taking a peek. ... sub write_sock { ...
    (comp.lang.perl.modules)
  • Chat client/server print failed
    ... This is a chat client wrote in perl Gtk2. ... is the print statement in the send_msg_all sub. ... leave the server running for testing purposes. ... # just read means there is a complete request waiting ...
    (comp.lang.perl.misc)
  • Re: runaway memory leak with LWP and Fork()ing on Windows
    ... child is immediantly given the next task as long as there are any ... sub new { ... # registers one or more callback routines with the agent ... my $self = shift() or return; ...
    (comp.lang.perl.misc)
  • Re: Macro possible?
    ... The following sub will handle multiple postings. ... Use this sub like you used the old one except select a range of client IDs ... You won't see the client file being updated. ... 'Select the client data to be posted. ...
    (microsoft.public.excel.worksheet.functions)
  • Re: event propagation
    ... if you want to raise an event from many child objects to a single ... Private Sub Form_Load ... Private Sub Mom_Shouting(Kid As Child, Msg As String) ...
    (microsoft.public.vb.general.discussion)