Could you quantify "A lot of data" ?

The only suspicious thing I see in the code is :

        $client_socket = $socket->accept();

        # Push new client connection to it's own thread
        push (@clients, threads->create(\&clientHandler, $client_socke
+t));
[download]

I would rather see that as:

        my $client_socket = $socket->accept();
[download]

My thinking (Probably pretty low probability, unless a lot of clients attempt simultaneous connect) is that this may prevent a potential race condition where the content of $client_socket changes before the invoked thread has had a chance to copy it.

Hello NetWallah,

First of all, thanks for your answer.

And about the "lot of data" I'm doing test with files of more or less 100k lines of log file.

Usually the server will handle maxium 3-4 lines per connection and then parse it and update a table in mysql and log it to a csv file but I want it to be stable and dont break if any server do a full update of 10k-20k lines of logs

I tried to delete the global declaration and declare it in the while(1) loop, but it still breaks with only 1 connection. If I try it with

The problem I think is related to the writing on the log file, because if I comment the line that open the report file in append mode and write the buffer it breaks.

Now I'm doing tests with 3 simultaneous clients sending 250k lines in loop to the server and it handles it perfectly if I dont write it to the file, only print the ouptut to the console

    while(my $buffer = <$client_socket>){
        ....
        open(my $fh, '>>', $output) or die "Could not open file '$outp
+ut' $!";
        print $fh $buffer;
    }
[download]

And the full code with the changes your recommendations and with the log output commented

#!/usr/bin/perl

use strict;
use warnings;
use threads;

use IO::Socket;

my $host    = '127.0.0.1';
my $port    = '1337';
my $proto    = 'tcp';
my $debug    = 1;

my $output     = 'report.txt';

my @allowed_ips = ('127.0.0.1');

sub Main
{
    # flush after every write
    $| = 1;

    # Bind to listening address and port
    my $socket    = new IO::Socket::INET(
        LocalHost => $host,
        LocalPort => $port,
        Proto     => $proto,
        Listen    => 5,
        Reuse     => 1
    ) or die "ERROR > Could not open socket: ".$!."\n";

    print "INFO  > Waiting for client connections on tcp:[$host]:$port
+...\n";

    my @clients = ();

    while(1){
            # Waiting for new client connection
            my $client_socket = $socket->accept();

            # Push new client connection to it's own thread
            push (@clients, threads->create(\&clientHandler, $client_s
+ocket));
            foreach(@clients){
                if($_->is_joinable()) {
                    $_->join();
                }
            }
    }
    $socket->close();
    return 1;
}

sub clientHandler
{
    # Socket is passed to thread as first (and only) argument.
    my ($client_socket) = @_;

    # Create hash for user connection/session information and set init
+ial connection information.
    my %user            = ();
    $user{peer_address} = $client_socket->peerhost();
    $user{peer_port}    = $client_socket->peerport();

    unless (client_allowed($user{peer_address})){
        print $client_socket "Server > Connection denied.\n";
        print "WARN  > Connection from $user{peer_address}:$user{peer_
+port} denied by IP policy.\n";
        $client_socket->shutdown(2);
        $client_socket->close();
        threads->exit();
    }

    print "INFO  > Client ".$user{peer_address}.":".$user{peer_port}."
+ has been conected.\n";

    # Let client know that server is ready for commands.
    print $client_socket "Server > Welcome to raClus-Server $user{peer
+_address}\n$user{peer_address}> ";

    # Listen for commands while client socket remains open
    while(my $buffer = <$client_socket>){

        # Accept the command `PING` from client with optional argument
+s
        if($buffer =~ /^PING(\s|$)/i)        {
            print $client_socket "Server > Pong!\n";
        }

        # Accept the command `HELLO` from client with optional argumen
+ts
        if($buffer =~ /^HELLO(\s|$)/i){
            print $client_socket "Server > Hello!\n";
            print $client_socket "Server > Your IP:\t".$user{peer_addr
+ess}."\n";
            print $client_socket "Server > Your Port:\t".$user{peer_po
+rt}."\n";
        }

        # This will terminate the client connection to the server
        if($buffer =~ /^QUIT(\s|$)/i){
            # Print to client, and print to STDOUT then exit client co
+nnection & thread
            print $client_socket "Server > GOODBYE\n";
            print "INFO  > Client ".$user{peer_address}.":".$user{peer
+_port}." has been disconnected.\n";
            $client_socket->shutdown(2);
            threads->exit();
        }

        print "DEBUG > $buffer" if $debug;

        # Escribimos en fichero de texto
        #open(my $fh, '>>', $output) or die "Could not open file '$out
+put' $!";
        #print $fh $buffer;

        print $client_socket "$user{peer_address} > ";
    }
    print "INFO  > Client ".$user{peer_address}.":".$user{peer_port}."
+ has been disconnected.\n";

    # Client has exited so thread should exit too
    threads->exit();
}

sub client_allowed
{
    my $client_ip = shift;
    return grep { $_ eq $client_ip || $_ eq '0/0' || $_ eq '0.0.0.0/0'
+ } @allowed_ips;
}

# Start the Main loop
Main();
[download]

Then, the problem is with the output to the log file, can I make it asyncronous or save it in cache and write when it can?

Just checking if you meant Un-Commenting the open/print to append to $output would cause the program to break.

I suspect that multiple threads appending to a file may be giving you trouble.

I suggest starting a separate thread to collect the output, and append it to a file in a single thread.
You can use Thread::Queue to pass data to the collector thread.

                Memory fault   --   brain fried

In your code, try sprinkling warnings after socket operations, or print a debug message at critical points to see where your code fails when it crashes. Just as a longshot, that sometimes works, try putting $SIG{CHLD} = 'IGNORE' in your script.

If you are going to stick with a select() while loop, it sometimes is useful to test for $socket->can_write at an appropriate place to give an indication that the socket is still alive.

#!/usr/bin/perl
use warnings;
use strict;
use IO::Socket;
use IO::Select;

my @sockets;
my $machine_addr = 'localhost';
my $main_sock = new IO::Socket::INET(LocalAddr=>$machine_addr,
      LocalPort=>1200,
      Proto=>'tcp',
      Listen=>3,
            Reuse=>1,
            );

die "Could not connect: $!" unless $main_sock;
print "Starting Server\n";

my $readable_handles = new IO::Select();
$readable_handles->add($main_sock);

while (1)
{

#  my ($new_readable) = IO::Select->select($readable_handles, undef, u
+ndef, 0 ); # causes 100% cpu usage
  my ($new_readable) = IO::Select->select($readable_handles, undef, un
+def, undef );

  foreach my $sock (@$new_readable)
  {
    if ($sock == $main_sock)
    {
      my $new_sock = $sock->accept();
      $readable_handles->add($new_sock);
    }
    else
    {
   
     my $count = sysread $sock, my $buf, 1024; 
   
      print "$count\n";
   
      if ($buf)
      { 
        print "$buf\n";
        my @sockets = $readable_handles->can_write(1);
    print "@sockets\n";
    #print $sock "You sent $buf\n";
    foreach my $sck(@sockets){print $sck "$buf\n";}
        
      }
      else
      {
        $readable_handles->remove($sock);
        close($sock);
      }
    }
  }

}

print "Terminating Server\n";
close $main_sock;
getc();
[download]

#!/usr/bin/perl -w
use strict;
use IO::Socket;

my ( $host, $port, $kidpid, $handle, $line );
#unless ( @ARGV == 2 ) { die "usage: $0 host port" }
( $host, $port ) = @ARGV || ('localhost',8989);

# create a tcp connection to the specified host and port
$handle = IO::Socket::INET->new(
    Proto    => "tcp",
    PeerAddr => $host,
    PeerPort => $port
  )
  or die "can't connect to port $port on $host: $!";
$handle->autoflush(1);    # so output gets there right away
print STDERR "[Connected to $host:$port]\n";

# split the program into two processes, identical twins
die "can't fork: $!" unless defined( $kidpid = fork() );

# the if{} block runs only in the parent process
if ($kidpid) {

    # copy the socket to standard output
    while ( defined( $line = <$handle> ) ) {
                      print STDOUT $line;
                      }
    kill( "TERM", $kidpid );    # send SIGTERM to child
}

# the else{} block runs only in the child process
else {

    # copy standard input to the socket
    while ( defined( $line = <STDIN> ) ) {
        print $handle $line;
    }
}
[download]

Hello,

I finally switched to POE, It works great for what I need and today I was working in a script with SSL support and works great. Here is the code

#!/usr/bin/perl

use warnings;
use strict;

use POE qw(Component::Server::TCP);
use POE::Component::SSLify qw(Server_SSLify SSLify_Options);

my @allowed_ips    = ('127.0.0.1', '172.16.0.17', '172.16.0.1', '172.1
+6.0.225');
my $listen_address = '172.16.0.224';
my $listen_port    = '1337';
my $listen_conns   = '-1';
my $listen_alias   = 'rc-listener';

my $output         = '/home/projects/perl/rc-listener/unknown-commands
+.txt';

my $ssl            = 1;
my $ssl_certfile   = '/home/projects/perl/rc-listener/cert.crt';
my $ssl_keyfile    = '/home/projects/perl/rc-listener/cert.key';
my $ssl_version    = 'default';

POE::Component::Server::TCP->new(
    # Listen options
    Address             => $listen_address,
    Port                => $listen_port,
    Concurrency         => $listen_conns,
    Alias               => $listen_alias,

    # Server handlers
    Error               => \&handle_server_error,
    Started             => \&handle_server_started,
    Stopped             => \&handle_server_stopped,

    # Client handlers
    ClientPreConnect    => \&handle_client_pre_connect,
    ClientConnected     => \&handle_client_connect,
    ClientDisconnected  => \&handle_client_disconnect,
    ClientInput         => \&handle_client_input,
    ClientError         => \&handle_client_error,
    ClientFlushed       => \&handle_client_flushed,
);

# Start the server.
POE::Kernel->run();
exit 0;

sub handle_client_pre_connect
{
    my ($session, $heap, $socket) = @_[SESSION, HEAP, ARG0];
    my $session_id   = $session->ID;
    my $remote_ip    = $heap->{remote_ip};
    my $remote_port  = $heap->{remote_port};
    my $remote       = "[${remote_ip}]:${remote_port}";
 
    unless (client_allowed($remote_ip)){
        warn "ERROR > Connection from ${remote} with Session-ID ${sess
+ion_id} denied by IP Policy.\n";
        return undef;
    }


    if($ssl){
        eval { SSLify_Options($ssl_keyfile, $ssl_certfile, $ssl_versio
+n) };
        if($@){
            warn "ERROR > Server unable to load key or certificate fil
+e.\n";
            return undef;
        }

        my $ssl_socket = eval { Server_SSLify($socket) };
        if($@){
            warn "ERROR > Server unable to make an SSL connection.\n";
            return undef;
        }
        return $ssl_socket;
    } else {
        return $socket;
    }
}

sub handle_client_connect
{

    my ($session, $heap, $input) = @_[SESSION, HEAP, ARG0];
    my $session_id   = $session->ID;
    my $client       = $heap->{client};
    my $remote_ip    = $heap->{remote_ip};
    my $remote_port  = $heap->{remote_port};
    my $remote       = "[${remote_ip}]:${remote_port}";

    $client->put("Welcome ${remote} your Session-ID is ${session_id}")
+;
    $client->put("Type 'help' for a complete list of accepted commands
+");

    warn "WARN  > Client ${remote} connected with Session-ID ${session
+_id}\n";
}

sub handle_client_disconnect
{
    my ($session, $heap, $input) = @_[SESSION, HEAP, ARG0];
    my $session_id   = $session->ID;
    my $client       = $heap->{client};
    my $remote_ip    = $heap->{remote_ip};
    my $remote_port  = $heap->{remote_port};
    my $remote       = "[${remote_ip}]:${remote_port}";

    warn "WARN  > Client ${remote} with Session-ID ${session_id} disco
+nnected\n";
}

sub handle_client_input
{
    my ($session, $heap, $input) = @_[SESSION, HEAP, ARG0];
    my $session_id   = $session->ID;
    my $client       = $heap->{client};
    my $remote_ip    = $heap->{remote_ip};
    my $remote_port  = $heap->{remote_port};
    my $remote       = "[${remote_ip}]:${remote_port}";

    if ($input eq "quit") {
        $client->put("Goodbye ${remote}");
        $_[KERNEL]->yield("shutdown");
        return;
    }

    if ($input eq "ping") {
        $client->put("pong");
        return;
    }

    if ($input eq "whoami") {
        $client->put("Your IP Address is ${remote_ip}");
        $client->put("Your port is ${remote_port}");
        return;
    }

    if ($input eq "help") {
        $client->put("Really? C'mon, just type something!");
        return;
    }

    open(my $fh, '>>', $output) or die "Could not open file '$output' 
+$!";
    print $fh "${input}\n";

    #$heap->{client}->put("Received input: ".$input);
    warn "WARN  > Client ${remote} Session-ID ${session_id}: ${input}\
+n";
}

sub handle_client_error
{
    my ($syscall_name, $err_num, $err_str) = @_[ARG0..ARG2];
    warn "ERROR > Client: ${err_num} - ${err_str}\n";
}

sub handle_client_flushed
{
    my ($session, $heap, $input) = @_[SESSION, HEAP, ARG0];
    my $session_id   = $session->ID;
    my $client       = $heap->{client};
    my $remote_ip    = $heap->{remote_ip};
    my $remote_port  = $heap->{remote_port};
    my $remote       = "[${remote_ip}]:${remote_port}";

    warn "INFO  > Client ${remote} flushed\n";
}

sub handle_server_started
{
    warn "INFO  > Server [${listen_address}]:${listen_port} started\n"
+;
}

sub handle_server_stopped
{
    warn "INFO  > Server [".$listen_address."]:".$listen_port." stoppe
+d\n";

}

sub handle_server_error
{
    my ($syscall_name, $err_num, $err_str) = @_[ARG0..ARG2];
    warn "ERROR > Server: ${err_num} - ${err_str}\n";
}

sub client_allowed
{
    my $client_ip = shift;
    return grep { $_ eq $client_ip || $_ eq '0/0' || $_ eq '0.0.0.0/0'
+ } @allowed_ips;
}
[download]

It's working like I want, obviusly still need a lot of work but hey, for now it's working pretty good

Now the next thing I want is to make some authentication mechanism, any hint?

What I was thinking is to save a plain text "database" or a postgresql table with a relation of ip address and token and match each IP address with the token

The database connector and checks it's not the big deal here, what I need is some type of auth in the connect handle or something to not be very database intensive, for example I'm thinking to load the entire table to an array on load the listener and make it "static" and refresh the array every 30 seconds with a subroutine or something

Really this is the "thing" I don't know how to do, what I'm trying to do is to make some bolean variable with the session-id and after first check insert it into the array and on each read/write from the client check it with the array

I'm near to the answer or anyone have another mechanism to achieve this?

Thanks for all, I really appreciate all the comments

It works for me (and quite impressively too++). Maybe you are not running a proper OS?

It is worth checking if number of open files or number of simultaneous connections at server is exceeded.

Anyway, here is a client I whipped up to test your server:

#!/usr/bin/perl -w

# Program to connect to a server (set HOST and PORT below)
# and send some commands to it randomly chosen from the
# list of commands (see @COMMANDS below) with some
# arguments if randomly decided.
# After sending each command it displays output received
# and then sleeps for some random time specified by
# the command line options: commands-per-second-min and -max
# When 'time-to-live' seconds have elapsed (more or less)
# the client shuts down.
#
# Usage: client.pl TTL cps-min cps-max
# TTL: will shutdown in TTL seconds more or less
# cps-min, cps-max: send bettwen cps-min and cps-max
# commands (request) per second to the server.
#
# Author: bliako
# 28/09/2018
# for https://perlmonks.org/?parent=1223158;node_id=3333
#

use strict;
use warnings;

use Net::Telnet;
use Time::HiRes;

my @COMMANDS = qw/PING HELLO/;
my ($HOST, $PORT) = ('127.0.0.1', '1337');

if( scalar(@ARGV) != 3 ){ print STDERR "Usage : $0 time-to-live comman
+ds-per-second-min commands-per-second-max\n"; exit(1) }
my ($ttl, $cps_min, $cps_max) = @ARGV;

my @queue = ();

my $attl = $ttl;
# calculate seconds between commands (can be fractional and less than 
+1)
# cps: commands-per-second
# spc: seconds-between-commands
my ($spc_min, $spc_max) = sort (1.0/$cps_min, 1.0/$cps_max);
while($attl > 0 ){
        # calculate sleep time before running this command
        my $rsbc = $spc_min + rand($spc_max-$spc_min);

        # get a random command
        my $cmd = $COMMANDS[int(rand(scalar(@COMMANDS)))];
        if( rand() < 0.5 ){
                # add optional args to command randomly
                $cmd .= " optional-argument=".int(rand(100000));
        }

        # add command and sleep time to queue
        push @queue, [$cmd, $rsbc];

        # reduce time-to-live
        $attl -= $rsbc;
}
# end the session
push @queue, ['QUIT 123', $spc_min];

my $num_cmds = scalar(@queue);

print "$0 : here is the list of comamnds and sleep times to send to se
+rver:\n";
print $_->[0].' and sleep for '.$_->[1]." s\n" for @queue;

my $tel = Net::Telnet->new(
        Host => $HOST,
        Port => $PORT
) or die "telnet new failed for ${HOST}:${PORT}";
$tel->open() or die "telnet open() failed, $!";
# important to set the prompt correctly
# otherwise you may get 'pattern match read eof'
# see also https://www.perlmonks.org/?node_id=672565
$tel->prompt('/>/') or die "telnet prompt() failed, $!";
my $time_started = time;
print "$0 : starting...\n";

foreach (@queue){
        my ($cmd, $rsbc) = @$_;
        print "$0 : sending command '$cmd' ... \n";
        my @lines = $tel->cmd($cmd);
        print "$0 : data received:\n".join("\n", @lines)."\n--- end da
+ta received.\n";
        print "$0 : sleeping for $rsbc s ...\n";
        Time::HiRes::sleep($rsbc);
}

print "$0 : shutting down ...\n";
$tel->close() or die "close(), $!";
print "$0 : done send $num_cmds commands in ".(time-$time_started)." s
+.\n";

exit(0);
[download]

Use it like so: client.pl 10 1 2 for sending between 1 and 2 commands per second over a total of 10 seconds to the server.

If you want to test multiple simultaneous client connections do this:

Replace seq 1 2 to seq 1 1000 to test 1000 clients simultaneously and see if your OS can handle that.

bw, bliako

Ok, finally got a working code, I tested it with 1000 simultaneous clients running random commands and works pretty well.

I'm using 3 shared hashes to mantain a shared relation between IP'ss and tokens for each one

#!/usr/bin/perl

use warnings;
use strict;
use threads;
use threads::shared;

use DBI;
use POE qw(Component::Server::TCP);
use POE::Component::SSLify qw(Server_SSLify SSLify_Options);
use Getopt::Long;

my %allowed : shared;
my %token : shared;
my %auth : shared;

my $loglevel      = 5;

# MySQL connection variables
my $dbhost         = "127.0.0.1";
my $dbname         = "db_mydb";
my $dbtable        = "tab_mytable";
my $ipcol          = "col_ip_address";
my $tokencol       = "col_token";
my $dbuser         = "root";
my $dbpass         = "*****";
my $dbport         = "3306";

my $listen_address = '127.0.0.1';
my $listen_port    = '1337';
my $listen_conns   = '100';

my $ssl            = 0;
my $ssl_certfile   = 'listener.crt';
my $ssl_keyfile    = 'listener.key';
my $ssl_version    = 'default';

GetOptions(
    # Help handler
    'help|h'       => \&handle_help,

    # SSL related options
    'ssl=i'        => \$ssl,
    'cert=s'       => \$ssl_certfile,
    'key=s'        => \$ssl_keyfile,

    # Listen options
    'address=s'    => \$listen_address,
    'port=i'       => \$listen_port,
    'conns=i'      => \$listen_conns,

    # MySQL options
    'dbhost=s'     => \$dbhost,
    'dbname=s'     => \$dbname,
    'dbtable=s'    => \$dbtable,
    'ipcol=s'      => \$ipcol,
    'tokencol=s'   => \$tokencol,
    'dbuser=s'     => \$dbuser,
    'dbpass=s'     => \$dbpass,
    'dbport=i'     => \$dbport,

    # Misc options
    'loglevel=i'   => \$loglevel

);

param_check($ssl, $ssl_certfile, $ssl_keyfile, $listen_address, $liste
+n_port, $listen_conns);

threads->new(\&update_tokens);

POE::Component::Server::TCP->new(
    # Listen options
    Address             => $listen_address,
    Port                => $listen_port,
    Concurrency         => $listen_conns,

    # Server handlers
    Error               => \&handle_server_error,
    Started             => \&handle_server_started,
    Stopped             => \&handle_server_stopped,

    # Client handlers
    ClientPreConnect    => \&handle_client_pre_connect,
    ClientConnected     => \&handle_client_connect,
    ClientDisconnected  => \&handle_client_disconnect,
    ClientInput         => \&handle_client_input,
    ClientError         => \&handle_client_error,
    ClientFlushed       => \&handle_client_flushed,
);

# Start the server.
POE::Kernel->run();
exit 0;

sub handle_client_pre_connect
{
    my ($session, $heap, $socket) = @_[SESSION, HEAP, ARG0];
    my $session_id   = $session->ID;
    my $remote_ip    = $heap->{remote_ip};
    my $remote_port  = $heap->{remote_port};
    my $remote       = "[${remote_ip}]:${remote_port}";

    unless (client_allowed($remote_ip)){
        logger("ERROR", "Connection from ${remote} with Session-ID ${s
+ession_id} denied by IP Policy");
        return undef;
    }

    if($ssl){
        eval { SSLify_Options($ssl_keyfile, $ssl_certfile, $ssl_versio
+n) };
        if($@){
            logger("ERROR", "Server unable to load key or certificate 
+file.");
            return undef;
        }

        my $ssl_socket = eval { Server_SSLify($socket) };
        if($@){
            logger("ERROR", "Server unable to make an SSL connection."
+);
            return undef;
        }
        return $ssl_socket;
    } else {
        return $socket;
    }
}

sub handle_client_connect
{

    my ($session, $heap, $input) = @_[SESSION, HEAP, ARG0];
    my $session_id   = $session->ID;
    my $client       = $heap->{client};
    my $remote_ip    = $heap->{remote_ip};
    my $remote_port  = $heap->{remote_port};
    my $remote       = "[${remote_ip}]:${remote_port}";

    $client->put("Welcome ${remote} your Session-ID is ${session_id}")
+;
    $client->put("Type 'help' for a complete list of accepted commands
+");

    logger("WARN", "Client ${remote} connected with Session-ID ${sessi
+on_id}");
}

sub handle_client_disconnect
{
    my ($session, $heap, $input) = @_[SESSION, HEAP, ARG0];
    my $session_id   = $session->ID;
    my $client       = $heap->{client};
    my $remote_ip    = $heap->{remote_ip};
    my $remote_port  = $heap->{remote_port};
    my $remote       = "[${remote_ip}]:${remote_port}";

    if($auth{$session_id}){
        delete $auth{$session_id};
        logger("WARN", "Client ${remote} with Session-ID ${session_id}
+ logged out");
    }
    logger("WARN", "Client ${remote} with Session-ID ${session_id} dis
+connected");
}

sub handle_client_input
{
    my ($session, $heap, $input) = @_[SESSION, HEAP, ARG0];
    my $session_id   = $session->ID;
    my $client       = $heap->{client};
    my $remote_ip    = $heap->{remote_ip};
    my $remote_port  = $heap->{remote_port};
    my $remote       = "[${remote_ip}]:${remote_port}";

    if ($input =~ /^login(\s|$)/i){
        if (auth_check($session_id)){
            $client->put("${remote} with Session-ID ${session_id} Alre
+ady logged in!");
        } else {
            my @login = split /\s+/, $input;
            if(token_check($remote_ip, $login[1])){
                $auth{$session_id} = 1;
                $client->put("Logged in with Session-ID: ${session_id}
+!");
                logger("WARN", "Client ${remote} with Session-ID ${ses
+sion_id} logged in");
            } else {
                $client->put('Access denied!');
                $_[KERNEL]->yield("shutdown");
                logger("ERROR", "Client ${remote} with Session-ID ${se
+ssion_id} failed login attempt");
            }
        }
        return;
    }

    if ($input eq "quit") {
        $client->put("Goodbye ${remote}");
        $_[KERNEL]->yield("shutdown");
        return;
    }

    if (auth_check($session_id)){
        if ($input eq "ping") {
            $client->put("pong");
            return;
        }

        if ($input eq "logout") {
            delete $auth{$session_id};
            $client->put("Logged out from Session-ID: ${session_id}");
            logger("WARN", "Client ${remote} with Session-ID ${session
+_id} logged out");
            return;
        }

        if ($input eq "whoami") {
            $client->put("Your IP Address is ${remote_ip}");
            $client->put("Your communication port is ${remote_port}");
            return;
        }

        if ($input eq "help") {
            $client->put("Only can use quit if you want to exit");
            return;
        }

        logger("WARN",  "Client ${remote} Session-ID ${session_id}: ${
+input}");
    } else {
        logger("WARN", "Client ${remote} with Session-ID ${session_id}
+ tried input: ${input}");
        $client->put('Login required!');
    }
}

sub handle_client_error
{
    my ($syscall_name, $err_num, $err_str) = @_[ARG0..ARG2];
    logger("ERROR", "Client: ${err_num} - ${err_str}");
}

sub handle_client_flushed
{
    my ($session, $heap, $input) = @_[SESSION, HEAP, ARG0];
    my $session_id   = $session->ID;
    my $client       = $heap->{client};
    my $remote_ip    = $heap->{remote_ip};
    my $remote_port  = $heap->{remote_port};
    my $remote       = "[${remote_ip}]:${remote_port}";

    logger("INFO", "Client ${remote} flushed");
}

sub handle_server_started
{
    logger("WARN", "Server [${listen_address}]:${listen_port} started"
+);
}

sub handle_server_stopped
{
    logger("WARN", "Server [${listen_address}]:${listen_port} stopped"
+);
}

sub handle_server_error
{
    my ($syscall_name, $err_num, $err_str) = @_[ARG0..ARG2];
    if($err_num){
        logger("ERROR", "Server: ${err_num} - ${err_str}");
    }
}

sub update_tokens
{
    my $dbi_dsn  = "DBI:mysql:database=${dbname};host=${dbhost};port=$
+{dbport}";
    my %sql_opts = ( PrintError => 0 );
    my @sql_conn = ($dbi_dsn, $dbuser, $dbpass, \%sql_opts);

    my $dbi_conn = DBI->connect(@sql_conn);
    if (!$dbi_conn){
        logger("FATAL", "Unable to connect to ${dbhost}:${dbport} - $D
+BI::errstr");
        logger("FATAL", "Retry in 60 seconds...");
        sleep 60;
    } else {
        logger("INFO", "Connected to ${dbhost}:${dbport}");
    }

    my $dbsel_stmt = $dbi_conn->prepare("SELECT ${ipcol}, ${tokencol} 
+FROM ${dbtable}");

    while (1){
        logger("INFO", "Running auth-update worker child process");

        unless ($dbi_conn->ping) {
            logger("FATAL", "Unable to connect to ${dbhost}:${dbport},
+ retry in 60 seconds");
            sleep 60;
            $dbi_conn = DBI->connect(@sql_conn);
        }

        if($dbsel_stmt->execute()){
            my %newallow;
            while (my @array = $dbsel_stmt->fetchrow_array){
                $newallow{$array[0]} = 1;
                if($token{$array[0]}){
                    if($token{$array[0]} ne $array[1]){
                        $token{$array[0]} = $array[1];
                        logger("INFO", "Token for $array[0] updated");
                    }
                } else {
                    $token{$array[0]} = $array[1];
                    logger("INFO", "Added token for IP $array[0]");
                }
            }

            for my $ip (keys %token){
                if(!$newallow{$ip}){
                    logger("INFO", "${ip} removed from allowed IP's");
                    delete $allowed{$ip};
                    delete $token{$ip};
                } else {
                    if(!client_allowed($ip)){
                        $allowed{$ip} = 1;
                        logger("INFO", "${ip} added to allowed IP's");
                    }
                }
            }

            logger("INFO", "Done auth-update worker child process");
        } else {
            logger("FATAL", "Cannot execute SQL Statement");
        }
        sleep 30;
    }
}

sub token_check
{
    my ($client_ip, $input) = @_;
    if (!defined $input || $input eq ''){
        return undef;
    } else {
        if ($input eq $token{$client_ip}){
            return 1;
        } else {
            return undef;
        }
    }
}

sub auth_check
{
    my $session_id = shift;
    return $auth{$session_id};
}

sub client_allowed
{
    my $ip = shift;
    return $allowed{$ip};
}

sub param_check
{
    my ($ssl, $ssl_certfile, $ssl_keyfile, $listen_address, $listen_po
+rt, $listen_conns) = @_;
    if($ssl){
        logger("INFO", "SSL support enabled");
        if(-e $ssl_certfile){
            logger("INFO", "SSL Certificate file loaded");
        } else {
            logger("FATAL", "SSL enabled and no certificate file found
+!");
            exit(1);
        }
        if(-e $ssl_keyfile){
            logger("INFO", "SSL Key file loaded");
        } else {
            logger("FATAL", "SSL enabled and no key file found!");
            exit(1);
        }
    } else {
        logger("INFO", "SSL support not enabled");
    }

    if($listen_address =~/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$
+/ && (($1<=255 && $1 >= 0) && ($2<=255 && $2 >= 0) && ($3<=255 && $3 
+>= 0)  && ($4<=255 && $4 >= 0))){
        logger("INFO", "IPv4 Address parsed correctly: ${listen_addres
+s}");
    } else {
        logger("FATAL", "Invalid IPv4 Address provided: ${listen_addre
+ss}");
        exit(1);
    }
    if(($listen_port < 65536) && ($listen_port > 0)){
        logger("INFO", "Port number parsed correctly: ${listen_port}")
+;
    } else {
        logger("FATAL", "Invalid port number provided: ${listen_port}"
+);
        exit(1);
    }
    if($listen_conns >= -1){
        logger("INFO", "Simultaneous connections parsed correctly: ${l
+isten_conns}");
    } else {
        logger("FATAL", "Invalid simultaneous connections provided: ${
+listen_conns}");
        exit(1);
    }
}

sub logger {
    my ($level, $msg) = @_;
    my $numlevel = 0;
    if ($level eq 'FATAL') {
        $numlevel = 1;
    } elsif ($level eq 'ERROR') {
        $numlevel = 2;
    } elsif ($level eq 'WARN') {
        $numlevel = 3;
    } elsif ($level eq 'INFO') {
        $numlevel = 4;
    } elsif ($level eq 'DEBUG') {
        $numlevel = 5;
    } else {
        $numlevel = 4;
    }
    if ($numlevel <= $loglevel) {
        warn "$level: $msg\n";
    }
}

sub handle_help
{
    print "\nUsage ${0} [OPTS]\n\n";
    print "Available options:\n\n";
    print "General options:\n";
    print "    --help     => No arguments expected, will show this hel
+p text\n";
    print "    --loglevel => Number between 0 and 5 expected.\n";
    print "                  0 - DISABLED: Log disabled\n";
    print "                  1 - FATAL: Fatal logging only\n";
    print "                  2 - ERROR: Fatal and error logging\n";
    print "                  3 - WARN: Fatal, error and warn logging\n
+";
    print "                  4 - INFO: Fatal, error, warn and info log
+ging\n";
    print "                  5 - DEBUG: All logging\n";
    print "\nSSL Related options:\n";
    print "    --ssl      => Accepted values:\n";
    print "                  1 - Enable SSL support (cert and key) opt
+ion required\n";
    print "                  0 - Don't enable SSL support, only plain 
+text support\n";
    print "    --cert     => Certificate file path required for SSL en
+cription\n";
    print "    --key      => Certificate key file path required for SS
+L encription\n";
    print "\nConnection options:\n";
    print "    --address  => Listening address, default \"${listen_add
+ress}\"\n";
    print "    --port     => Listening port, default \"${listen_port}\
+"\n";
    print "    --conns    => Concurrent connections, default \"${liste
+n_conns}\"\n";
    print "\nMySQL options:\n";
    print "    --dbhost   => Database server IP, default \"${dbhost}\"
+\n";
    print "    --dbname   => Database table name, default \"${dbname}\
+"\n";
    print "    --dbtable  => MySQL table name, default \"${dbtable}\"\
+n";
    print "    --ipcol    => IP column name in MySQL table, default \"
+${ipcol}\"\n";
    print "    --tokencol => Token column name in MySQL table, default
+ \"${tokencol}\"\n";
    print "    --dbuser   => Database username, default \"${dbuser}\"\
+n";
    print "    --dbpass   => Database password, default \"${dbpass}\"\
+n";
    print "    --dbport   => Database server port number, default \"${
+dbport}\"\n";
    exit(0);
}
[download]

I'm not 100% sure about the handling of the thread element and if all is ok, but is working.

I don't know if it will be helpfuly for someone but as I got lot of help from perlmonks I want it to be here for everyone who wants to use it or use some parts of it

What I need now is some tips or something that can be improved, but for now, It's working in replacement to my old PHP api and is about 400-500% faster.

also, add the following in your server where you handle the QUIT case:

my $ret = $client_socket->shutdown(2);
if( ! defined($ret) ){ print STDERR "$0 : error shutdown() : not a val
+id filehandle.\n"; }
elsif( $ret == 0 ){ print STDERR "$0 : error shutdown() : $!\n"; }
else { print "$0 : socket shutdown OK\n"; }
[download]