Richard Luckhurst wrote:
> Hi List
Hello,
> I have just been given the task of finding out why a perl sockets liste=
ner
> 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 ser=
ver 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=
=2E
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.
>=20
> What is happening is when the child exits it is killing the parent proc=
ess 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 proc=
ess was
> manually killed.
>=20
> I am not very familiar with perl so I am asking the list for any guidan=
ce as to
> where the script may be failing.
>=20
> I am including the code for the listener below.
>=20
> #!/usr/bin/perl
use warnings;
use strict;
> #
> # Name: listener.pl
> #
> #
> # Sub index:
> # exCheckTrustedIP
> # GetSock
> # process_line
> # ProcessRequests
> # Reaper
> # ServiceClients
> # SetProperties
> # StartDaemon
> #
> #
>=20
> #-USE------------------------------------------------------------------=
---------
> $debug =3D 1;
>=20
> use IO::Socket;
> use POSIX ":sys_wait_h"; # (for WNOHANG)
That should now be:
use POSIX 'WNOHANG';
> use Fcntl;
>=20
> #-CONSTANTS------------------------------------------------------------=
---------
>=20
> my ($SERVER_ADDR, $SERVER_****T, $LISTENER, $DATABASE_NAME, $DATABASE_PO=
RT,
> $DATABASE_HOST, $USER_ID, $PASSWORD, $DATABASE_LOCATION, $MESSAGE_T=
IMEOUT,
> $IDLE_TIMEOUT,) =3D "";
That is the same as:
my $SERVER_ADDR =3D "":
my ($SERVER_****T, $LISTENER, $DATABASE_NAME, $DATABASE_****T,
$DATABASE_HOST, $USER_ID, $PASSWORD, $DATABASE_LOCATION,=20
$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 d=
atabase you are=20
> # meant to be talking to (eg hack, dev), talk to the database specified=
=2E 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 specifi=
ed in the
> # list.=20
> # Format table_name =3D> table_name,database_name,hostname,****tname,use=
r_id,password
> =20
> %SPECIAL_CASES =3D '';
Hashes should be assigned key/value pairs. With warnings enabled that=20
would produce a warning message.
> %SPECIAL_CASES =3D
But why the other assignment? You are just overwriting the ( '', undef=20
) pair that you previously assigned.
> (
> ex_time =3D> "ex_time:exodus:203.xxx.xxx.x:5432:xxxxxx:=
xxxxxxx",
> time_control =3D> "time_control:exodus:203.xxx.xxx.x:54=
32:xxxxxx:xxxxxxx"
> );
>=20
>=20
> sub StartDaemon
> {
> =20
> print "Listener started\n";
> =20
> SetProperties($_[0]);
>=20
> my $pid;
> if ($pid =3D 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 =3D fork()) { exit; }
Why are you fork()ing again and exit()ing?
> $0 =3D "$LISTENER: accepting connections on $SERVER_****T"; # f=
or =B4ps=B4
> ServiceClients( GetSock() ); # wait for incoming requests=
> } =20
> }
> #----------------------------------------------------------------------=
---------
> # Changes:
> # 13AUG03 DT Created sub.
>=20
> sub SetProperties
> {
> my %properties =3D GetAllSiteRecordValues($_[0]); # eg. $_[0]=
=3D "hack"
>=20
> $SERVER_ADDR =3D $properties{"listener.server.addr"}; # eg. 203.x=
xx.xxx.x
> $SERVER_****T =3D $properties{"listener.server.****t"}; # eg. 15555=
> $DATABASE_NAME =3D $properties{"listener.db.name"}; # eg. hack
>=20
> $DATABASE_****T =3D $properties{"listener.db.****t"}; # eg. 5432
> $DATABASE_HOST =3D $properties{"listener.db.addr"}; # eg. 203.x=
xx.xxx.x
> $USER_ID =3D $properties{"listener.db.user.id"}; # eg. beanm=
an
> $PASSWORD =3D $properties{"listener.db.user.password"};
>=20
> $MESSAGE_TIMEOUT =3D $properties{"listener.timeout.message"}; # eg.=
30 # Max pause WITHIN a MESSAGE (seconds)
> $IDLE_TIMEOUT =3D $properties{"listener.timeout.idle"}; # eg.=
600 # Max Pause BETWEEN messages (seconds)
>=20
> $LISTENER =3D $DATABASE_NAME. "_listener";
> $DATABASE_LOCATION =3D "dbname=3D$DATABASE_NAME;host=3D$DATABASE_HO=
ST;****t=3D$DATABASE_****T";
>=20
> return 1;
> }
> #----------------------------------------------------------------------=
---------
>=20
> sub GetSock {
> # unlink $sockname;
> my $sock =3D IO::Socket::INET->new(
> Local****t =3D> $SERVER_****T,
> Type =3D> SOCK_STREAM,
> Reuse =3D> 1,
> Listen =3D> 10,
> ) or die "$0: error starting $LISTENER daemon on '$SERVE=
R_****T': $@[EMAIL PROTECTED]
";
> # you might want to change permissions and owner****p, e.g.:
> #chmod 0600, $sockname;
> #chown scalar getpwnam('nobody'), 0, $sockname;
> return $sock;
> }
> #----------------------------------------------------------------------=
---------
>=20
> sub ServiceClients {
> my $sock =3D ****ft;
> $SIG{CHLD} =3D \&Reaper;
>=20
> my $client;
> while ( $client =3D $sock->accept() ) {
> my $pid =3D 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
> }
> }
> #----------------------------------------------------------------------=
---------
>=20
> sub ProcessRequests {
> my $sock =3D ****ft;
> my ($inline, $outline) =3D "";
That is the same as:
my $inline =3D "";
my $outline;
> $| =3D 1; # don't buffer output - shouldn't need \n=
to print
Note that $| only applies to the currently selected filehandle. To=20
which filehandle did you want this to apply?
> $0 =3D "$LISTENER: child handling requests..."; # for =B4ps=B4
>=20
> my $db_handle =3D &ex_open_pg_connection($DATABASE_LOCATION, $USER_=
ID, $PASSWORD);
> if (!$db_handle) {
> exCloseWithError($sock, "Database error: Couldn't connect to da=
tabase");
> }
> exCheckTrustedIP($db_handle, $sock);
>=20
> # Set non-blocking IO (from O'Reilly Perl)
> $flags =3D '';
> fcntl($sock, F_GETFL, $flags) or die "Error: $!\n";
> $flags |=3D O_NONBLOCK;
> fcntl($sock, F_SETFL, $flags) or die "Error: $!\n";
>=20
> # Read 8192 bytes at a time until hex 04 then start again
>=20
> $buf =3D "";
> $prev_message_time =3D time; # time last message was received.
> $start_message_time =3D ''; # > null means partial message re=
ceived
> =20
> 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=20
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 chil=
d process)
> # Attempt to read data into buffer.
> $i =3D recv $sock, $buf, 8192, '';
> if (!$buf) {
> # No data received - check for errors and timeouts.
> if ($i < -1) {
> exCloseWithError($sock, "Internal error: TCP Error. Rea=
d() returned: $i");
> }
>=20
> # Check whether message receive in progress - if so check f=
or timeout.
> $cur_time =3D 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 l=
ong it's been quiet...
> if ($cur_time > $prev_message_time + $IDLE_TIMEOUT) {
> exCloseWithError($sock, "A timeout has occurred aft=
er $IDLE_TIMEOUT seconds of inactivity. >> Connection closed.");
> }
> }
> }
> else
> {
> # Some data received - check what we got.
> if (($eom_idx =3D (index $buf, "\x04")) > -1)
> {
> # End_Of_Message received. Finalize bigbuf - should no=
w be entire message string
> $end_buf =3D substr($buf, 0, $eom_idx);
> $bigbuf .=3D $end_buf; # should now be in form chk=
lenRMidRMdata
>=20
> $outline =3D exProcessMessage($db_handle, $sock, $bigbu=
f);
> =20
> print LOG "OUT:$outline\n";
> =20
> printf $sock $outline;
>=20
> $prev_message_time =3D time;
> $bigbuf =3D substr($buf, $eom_idx+1);
> $buf =3D "";
> $start_message_time =3D ''; # NO message currentl=
y being received
> } else {
> $start_message_time =3D time;
> $bigbuf .=3D $buf;
> $buf =3D "";
> }
> }
> }
> =20
> close LOG;
> &ex_close_pg_connection ($db_handle);
> }
> #----------------------------------------------------------------------=
---------
> # Checks if IP address at other end of socket is trusted, if not send e=
rror
> # message to socket and exit.
>=20
>=20
> sub exCheckTrustedIP
> {
> my ($db_handle, $sock, $debug) =3D @[EMAIL PROTECTED]
>=20
> # Get client IP address
> my $other_end =3D getpeername($sock)
> or die "$LISTENER: Couldn't identify other end: $!\n";
> my ($****t, $iaddr) =3D unpack_sockaddr_in($other_end);
> my $ip_address =3D inet_ntoa($iaddr);
>=20
> # Confirm that client IP is trusted - if full IP not in table, test=
on subnet
> my $read_ptr =3D ex_read_pg_data ($db_handle, "", "trusted_ips", "=
EQ", $ip_address, "", "0", "", "");
> my $found_ip =3D ****ft (@[EMAIL PROTECTED]
);
>=20
> if ($found_ip)
> {
> send $sock, "OK: Successfully connected to $SERVER_ADDR:$SERVER=
_****T - Hello, $ip_address\n", '';
> }
> else
> {
> # Test subnet - IP up to last . then 0 eg 203.113.254.0
> my $ip_last_dot =3D rindex ($ip_address, ".");
> my $subnet =3D substr($ip_address, 0, $ip_last_dot+1)."0";
Or alternately:
( my $subnet =3D $ip_address ) =3D~ s/[^.]+\z/0/;
> my $read_ptr =3D ex_read_pg_data ($db_handle, "", "trusted_ips=
", "EQ", $subnet, "", "0", "", "");
> my $found_sub =3D ****ft (@[EMAIL PROTECTED]
);
>=20
> if ($found_sub) { send $sock, "OK: Successfully connected to $S=
ERVER_ADDR:$SERVER_****T - Hello, $ip_address on subnet $subnet", ''; }
> else { printf $sock "ERROR: $ip_address is not a tru=
sted IP address. Please contact Exodus Systems Sup****t if you believe thi=
s IP should be on our Trusted IP list."; }
> }
> }
> #----------------------------------------------------------------------=
---------
> # Sends error message to client, then closes socket and exits
>=20
> sub exCloseWithError
> {
> my ($sock, $err_msg, $debug) =3D @[EMAIL PROTECTED]
>=20
> 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 bef=
ore
> # returning control to calling code
>=20
> sub exProcessMessage
> {
> my ($db_handle, $sock, $message, $debug) =3D @[EMAIL PROTECTED]
> my ($file) =3D '';
> =20
> # Check for first record mark
> $rm1idx =3D index ($message, $RM);
> if ($rm1idx =3D=3D -1) {
> print $sock "No Record mark in string - require 2";
> return;
> }
>=20
> $chk_len =3D substr($message, 0, $rm1idx);
> $msg =3D substr($message, $rm1idx+1);
> $msg_len =3D length($msg);
> if ($msg_len !=3D $chk_len)
> {
> print $sock "Checksum doesn't match - ensure message length sen=
t is correct: your length>$chk_len< and message length>$msg_len<";
> return;
> }
>=20
> @[EMAIL PROTECTED]
=3D split(/$RM/, $msg);
> $action =3D ****ft (@[EMAIL PROTECTED]
);
> my $file =3D lc $records[0];
^^
You are declaring $file a second time in the same scope. With warnings=20
enabled you would have received a warnings message about this.
> if ($action eq "W")=20
> {=20
> if ($SPECIAL_CASES{$file}) {$outline =3D exWriteSpecialCases($s=
ock, $db_handle, \@[EMAIL PROTECTED]
$debug);}
> else {$outline =3D exWriteToPG($db_handle=
, \@[EMAIL PROTECTED]
$debug); }
> }
> elsif ($action eq "M") { $outline =3D exProcessWebpayString(\@[EMAIL PROTECTED]
$debug); }
> else { $outline =3D "received action ->$action<-"; }
>=20
> if ($debug) { Debug($outline, "outline", "", "", "connection respo=
nse", "T", "Y"); }
>=20
> return $outline; #."\n"; # need \n for <socket> read to work...
> }
> #----------------------------------------------------------------------=
---------
>=20
> sub Reaper {
> while (waitpid(-1,WNOHANG) > 0) {}
That is usually written as:
1 while waitpid( -1, WNOHANG ) > 0;
> $SIG{CHLD} =3D \&Reaper;
> }
>=20
> #----------------------------------------------------------------------=
---------
> sub exWriteSpecialCases
> {
> =20
> my ($sock, $db_handle, $records_ptr, $debug) =3D @[EMAIL PROTECTED]
> my @[EMAIL PROTECTED]
=3D @[EMAIL PROTECTED]
you are just going to make a copy of @[EMAIL PROTECTED]
then why not just make=20
@[EMAIL PROTECTED]
the last argument and pass through the whole list instead of a=20
reference?
> my $file =3D lc (****ft (@[EMAIL PROTECTED]
));
> my $key =3D ****ft (@[EMAIL PROTECTED]
);
my ( $file, $key, @[EMAIL PROTECTED]
) =3D @[EMAIL PROTECTED]
$file =3D lc $file;
> my ($output) =3D "RESP:";
> =20
> # @[EMAIL PROTECTED]
should only have 1 element left now after having the first=
two=20
> # ****fted off
> =20
> my @[EMAIL PROTECTED]
=3D split (/\xFE/, $records[0]);=20
>=20
> @[EMAIL PROTECTED]
=3D split (/:/, $SPECIAL_CASES{$file});
> my $DATABASE_LOCATION =3D "dbname=3D$data_location[1];host=3D$data_=
location[2];****t=3D$data_location[3]";
> my $USER_ID =3D $data_location[4];
> my $PASSWORD =3D $data_location[5];
> =20
> my $db_handle =3D ex_open_pg_connection($DATABASE_LOCATION, $USER_I=
D, $PASSWORD);
^^
You are declaring $db_handle a second time in the same scope. With=20
warnings enabled you would have received a warnings message about this.
> exCheckTrustedIP($db_handle, $sock);
>=20
> =20
> $output .=3D &ex_write_pg_data($db_handle, "F", $file, $key, \@[EMAIL PROTECTED]
$debug);
> =20
> # close (DEBUG);
> ex_close_pg_connection ($db_handle);
> =20
> return $output;
> }
> #----------------------------------------------------------------------=
---------
>=20
> 1; #return true
Is this code being used as a module? If not then you don't need that=20
last line.
John
--=20
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
|
