perl TCP server daemon example (using socket module)

Thank you for visiting this page, this page has been update in another link Perl TCP Server Daemon example using socket module

Perl is a powerful script language, not just do simple stuff, but also can do complex stuff too.

Lots of people have trouble to figure out parent process, child process, socket communication with client and how to zombie a dead child process, etc..
Here is my example have everything in it. Defunct process free.

The main idea is that
Have a socket open for connection from client

Accept connection from client

Fork a child process

Handle the connection to child, then close parent process.

Child process can do whatever need to do with client

While parent process can deal with new connections.

Here is simple parent & child process example. After fork, two identical processes created. By adding while loop to them, parent process can continue process upcoming client connections, while child process deal with each request.

if( !defined($pid = fork) ) {

   printf( "Cannot fork: $!\n" );
}
elsif( $pid ) { # parent process
   printf( "New server started with PID: $pid, will be recycled after it's reap\n" );
}
else { # else I'm the worker child
   # do real stuff here
   exit;
}

Here is reaper example, while function is essential here if your script is going to deal with multiple connections from client at the same time, this is where most people have defunct process, who not using loop to recycle reaper child process.

sub REAPER
{
my ($childpid,$ex);
while (($childpid = waitpid(-1,WNOHANG) ) > 0 ) {
    $ex = $?;
    if( $ex ) {
      $ex = $ex/256;
    }
    if( $childpid == -1 ) {
      printf( "reaped a child's system command\n" );
    }
    else {
      printf( "PID $childpid: " . ($ex ? " (exit $ex)." : '.')."\n" );
    }
}
$SIG{CHLD} = \&REAPER;
return;
}

socket connection function is simple:

$proto = getprotobyname( 'tcp' );
socket( Server, PF_INET, SOCK_STREAM, $proto ) or printf( "socket: $!\n" );
setsockopt( Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1) ) or printf( "setsockopt: $!\n" );
bind( Server, sockaddr_in($g_port, INADDR_ANY) ) or printf( "bind: $!\n" );
listen( Server, SOMAXCONN ) or printf( "listen: $!\n" );

# set flushing
$| = 1;
$paddr = accept( Client, Server );
if( defined($paddr) ) {
    ($port,$iaddr) = sockaddr_in( $paddr );
    $name = gethostbyaddr( $iaddr, AF_INET );
    printf( "Connection from $name [".inet_ntoa($iaddr)."] at port $port\n" );
    $pid = getpid();

    syswrite( Client, "I'm main process $pid,I've got you connected, how are you! \n", $g_maxbuf) ;
  }

Putting things together, with checking and and verification, it comes up as a simple TCP server daemon script. Put your real business code into child process part. You have your own TCP server daemon!

It's a proved robust daemon, take a try, and drop me a question if you have.

Below is the whole simplified daemon in perl, put your real job in child part. You can also download it from attached file.

#!/usr/bin/perl

#= PACKAGES / SETUP ===========================================================
use warnings;
use strict;

BEGIN {
$ENV{ENV} = '';
$ENV{PATH} = "/bin:/usr/bin:/sbin:/usr/sbin";
@INC = (".", @INC);
}

use POSIX;
use Socket;

use lib qw(.);

#= CONSTANTS      =============================================================

#= GLOB VARIABLES =============================================================
## set defaults
our $g_port=12345;
my $g_maxbuf = 512 ;    ## need to get eventu. from config

#= SUBROUTINES ================================================================

###############################################################################
# SUB:
# PURPOSE:
#
# ARGS:
#
# NOTES:
# RETURNS:
###############################################################################
sub REAPER
{
my ($childpid,$ex);
while (($childpid = waitpid(-1,WNOHANG) ) > 0 ) {
    $ex = $?;
    if( $ex ) {
      $ex = $ex/256;
    }
    if( $childpid == -1 ) {
      printf( "reaped a child's system command\n" );
    }
    else {
      printf( "PID $childpid: " . ($ex ? " (exit $ex)." : '.')."\n" );
    }
}
$SIG{CHLD} = \&REAPER;
return;
}

###############################################################################
# SUB:   SysWrite
# PURPOSE: systemwrite
#
# ARGS:
#
# NOTES:
# RETURNS:
###############################################################################
sub SysWrite
{
my $res=$_[0] ;
my $buf="" ;
my $nr = 0 ;

syswrite( Client, $res, $g_maxbuf) ;
$res = 0 ;
eval {
      local $SIG{ALRM} = sub { die "alarm\n" };       # NB \n required
      alarm 120 ;
      $nr = sysread( Client, $buf, $g_maxbuf );
      alarm 0 ;
     };
die if $@ && $@ ne "alarm\n";       # propagate errors
    if ($@) {
      alarm 0;
      printf( "sysread time out , will be closed\n" );
      $res=6 ;
    }
if( $nr <= 0 ) {
    if($res != 6 ) {
      $res = 5 ;
    }
}
else {
    if(!($buf eq "act" )) {
      $res = 1 ;
    }
}
return($res) ;
}

#= MAIN Section begins ========================================================

my( $proto, $pid, $paddr, $port, $iaddr, $name );

$proto = getprotobyname( 'tcp' );
socket( Server, PF_INET, SOCK_STREAM, $proto ) or printf( "socket: $!\n" );
setsockopt( Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1) ) or printf( "setsockopt: $!\n" );
bind( Server, sockaddr_in($g_port, INADDR_ANY) ) or printf( "bind: $!\n" );
listen( Server, SOMAXCONN ) or printf( "listen: $!\n" );

# set flushing
$| = 1;

$SIG{CHLD} = \&REAPER;

while( 1 ) {
printf( "Ready to accept connection from client\n" );
if ( -f "/tmp/stoptest" ) {
    last;
}
$paddr = accept( Client, Server );
if( defined($paddr) ) {
    ($port,$iaddr) = sockaddr_in( $paddr );
    $name = gethostbyaddr( $iaddr, AF_INET );
    printf( "Connection from $name [".inet_ntoa($iaddr)."] at port $port\n" );
    $pid = getpid();
    syswrite( Client, "I'm main process $pid,I've got you connected, how are you! \n", $g_maxbuf) ;
    if( !defined($pid = fork) ) {
      printf( "Cannot fork: $!\n" );
    }
    elsif( $pid ) {
      printf( "New server started with PID: $pid, will be recycled after it's reap\n" );
      $pid = getpid();

      syswrite( Client, "parent feedback PID $pid,I've passed your connection to a child worker process, I'm closing connection.. bye bye!\n", $g_maxbuf) ;

      close Client ;
      sleep(0.1);
    }
    else {    # else I'm the worker child
      $pid = getpid();
      printf( "I'm child worker $pid, I'm trying to do something here for client!, please wait !\n" ) ;
      syswrite( Client, "I'm child worker $pid, trying to do something here for you, please wait !\n", $g_maxbuf) ;
      sleep 5;
      # do real stuff here
      syswrite( Client, "child worker $pid feedback, I'm closing connection.. bye bye!\n", $g_maxbuf) ;
      close Client ;
      exit 44;
    }
}
else {
     printf("message from pid $pid,see you !\n");
}
printf("here is after child,after sleep secs\n");
my $current_pid = getpid();
printf( "tracking main process $pid,$current_pid\n" ) ;
}
printf( "NOTE! daemon stopped! \n" ) ;
exit ( 0 ) ;

__END__

TEST run

$./simpledaemon.pl
Ready to accept connection from client

From another session, run

$telnet server 12345
Trying 192.168.1.1 ...
Connected to aaaa.
Escape character is '^]'.
I'm main process 10484,I've got you connected, how are you!
parent feedback PID 10484,I've passed your connection to a child worker process, I'm closing connection.. bye bye!
I'm child worker 10486, trying to do something here for you, please wait !

child worker 10486 feedback, I'm closing connection.. bye bye!
Connection closed by foreign host.

On daemon console, you will see the following message

Connection from client [192.168.1.1] at port 49948
New server started with PID: 10486, will be recycled after it's reap
here is after child,after sleep secs
tracking main process 10484,10484
Ready to accept connection from client
I'm child worker 10486, I'm trying to do something here for client!, please wait !
PID 10486: (exit 44).
message from pid 10484,see you !
here is after child,after sleep secs
tracking main process 10484,10484
Ready to accept connection from client

simpledaemon.pl

(4k)

Xinli Liu,

Sep 5, 2013, 1:55 PM

v.2

Comments