vr has asked for the wisdom of the Perl Monks concerning the following question:

Because of examples in documentation (while ( accept ... etc. ), I thought that an IO::Socket::INET object can be used to accept many connections with different clients, consecutively. However, this client-server example halts (hangs) trying to accept the 65th client.

# server
use strict;
use warnings;
use IO::Socket::INET;

STDOUT-> autoflush( 1 );
my $external = 'external.pl';

my $sock = IO::Socket::INET-> new(
    LocalHost => '127.0.0.1',
    LocalPort => 5001,
    Proto     => 'tcp',
    Listen    => 5,
    Reuse     => 1
) or die;

for ( my $i = 1;; $i ++ ) {
    print "# $i ";
    system 1, $^X, $external, $i;

    print ' accepting... ';
    my $client = $sock-> accept;

    print 'reading... ', <$client>;

    $sock-> shutdown( 2 );
    $client-> close;
    sleep 1
}

[download]

And "a client" (i.e. 'external.pl'):

# client
use strict;
use warnings;
use IO::Socket::INET;

my $sock = new IO::Socket::INET (
    PeerHost => '127.0.0.1',
    PeerPort => 5001,
    Proto    => 'tcp',
) or die;

print $sock "$ARGV[ 0 ]\n";
$sock-> close;

[download]

The magic "computeresqe" nature of the "64" number (remaining the same when sleeping for 3, rather than 1) makes me think, the solution is very close, I'm just missing something. But, I can't figure out what.

Perl is e.g. Strawberry 5.020 Win32

Replies are listed 'Best First'.
Re: Multiple consecutive connections to a socket (probably a stupid question)
by huck (Prior) on Dec 24, 2016 at 18:04 UTC
[reply]

      Oh, I see, thank you. Can there be negative effects, if I place

      1 while waitpid(-1, WNOHANG) > 0;

      immediately after the "system(1, ..." line? (I checked, it works. I suppose it marks a still running process to be "reaped automatically")

      One more question. Client code catches all errors, and therefore, in theory, it always sends a reply to "server". But, if it does something horrible and Perl interpreter crashes ("out of memory" or similar), can server somehow know about it? Maybe using PID returned by "system(1, ...".

      Edit (after reading huck's answer): It looks like my "idea" (where do I get them from? I don't know) about "marking for auto-reaping" is wrong. Then, the above line of code can be placed anywhere in the "server", if it's executed with the same (or more) frequency, as creating "clients". Which maybe means, the good place can be not after, but before calling "system". Number of "clients" is limited in real application.

[reply]
[d/l]

        While that code will reap anything that is already terminated, it does not insure that system calls terminate faster than they are generated. If the count is already at 64 You need some sort of counter that blocks the next system call from starting before one finishes.

        while there is a return code in $? right after the waitpid i dont think there is any way to capture any textual error when you use system(1,...)

[reply]
Re: Multiple consecutive connections to a socket - example event-driven server using IO::Select
by eyepopslikeamosquito (Archbishop) on Dec 26, 2016 at 00:06 UTC

    An alternative to your forking server is a single-threaded event-driven server using IO::Select.

    I've dug out some old code I used for testing Syslog a while back. I post the code in its entirety here, including output of an example run, in case it is of use to you or another monk (or me of the future :). Note that this code runs fine on both Unix and Windows.

    Here is the mock syslog server: 

    # mocksyslogserver.pl.

use strict;
use warnings;
use IO::Socket::INET;
use IO::Select;
use Sys::Hostname ();
use Time::HiRes   ();
use Getopt::Std   ();

# A mock syslog server.
# XXX: Could not find a way to find the length of the syslog message
# without parsing it.
# I am not aware of a guaranteed syslog "termination character"
# to indicate the syslog message is complete
# ... though terminating all messages with '\0' seems common.

my $SYSLOG_MIN_HDR_LEN = 1;
my $SYSLOG_MAX_MSG_LEN = 1024;

# From https://tools.ietf.org/html/rfc5424 (Syslog protocol).
#
#  The syslog protocol does not provide acknowledgment of message
#  delivery.  Though some transports may provide status information,
#  conceptually, syslog is a pure simplex communications protocol.
#  Note: Simplex = send in one direction only

sub usage
{
   print <<'DARLING_FASCIST_BULLY_BOY';

A mock syslog server.

usage: mocksyslogserver [-a accept-sleep-secs] [-r recv-sleep-secs] -p
+ port

Examples:
  mocksyslogserver -p 9949           Normal syslog server.
                                     Start up mock syslog server on po
+rt 9949.

  mocksyslogserver -p 9949 -a 3      Listen on port 9949, then sleep f
+or 3
                                     secs after client accepts.

  mocksyslogserver -p 9949 -r 3      Listen on port 9949, then sleep f
+or 3
                                     secs after each recv from client.

DARLING_FASCIST_BULLY_BOY
   exit 1;
}

sub get_datetime_stamp
{
   my ( $s, $m, $h, $d, $mon, $y ) = localtime;
   sprintf( "%02d:%02d:%02d", $h, $m, $s );
}

# -----------------------------------------------------------------
# Perl network programming notes
# ------------------------------
# Reading can be done with:
#  1) <$sock> - blocks till new line
#  2) read($sock, $buf, $len) - blocks till $len bytes received
#                               (like W Richard Stevens readn function
+ in C)
#  3) sysread($sock, $buf, $len) - may return less than asked for
#                                  (like read()/recv() in C)
# -----------------------------------------------------------------

# Return undef if client closed the $client socket.
sub recv_tcp_client
{
   my $client = shift;

   my $peerhost = $client->peerhost();
   my $peerport = $client->peerport();

   # my $peeraddr     = $client->peeraddr();
   # my $peerhostfull = gethostbyaddr( $peeraddr, AF_INET ) || "Cannot
+ resolve";

   # my $fromstr = "from $peerhost:$peerport (host=$peerhostfull) ";
   my $fromstr = "from $peerhost:$peerport ";

   my $data;

   # This one blocks until newline received.
   # $data = <$client>;

   #  This one blocks till $len bytes received (like Stevens readn fun
+ction in C)
   # my $hdr;
   # my $hdrlen = read( $client, $hdr, $SYSLOG_HDR_LEN );

   # This one may return less than asked for (like read()/recv() in C)
   # XXX: When we receive a '\0' we know the message is complete?
   my $msglen = sysread( $client, $data, $SYSLOG_MAX_MSG_LEN );

   # XXX: For now, just remove any NULLs in received data
   my $numnull = $data =~ tr/\0//d;

   if ( !defined($msglen) )
   {
      print '[Recv] ' . get_datetime_stamp() . ": $fromstr" . "<undef>
+ read error: $!\n";
      sleep(1);
      return;
   }
   if ( $msglen == 0 )
   {
      print '[Recv] ' . get_datetime_stamp() . ": $fromstr" . "read hd
+r eof\n";
      sleep(1);
      return;
   }
   if ( $msglen < $SYSLOG_MIN_HDR_LEN )
   {
      warn "error: read less than min bytes ($msglen < $SYSLOG_MIN_HDR
+_LEN)\n";
   }

   print '[Recv] '
      . get_datetime_stamp()
      . ": $fromstr"
      . "read data ok (len=$msglen, null=$numnull)\n";
   print '[Recv] ' . get_datetime_stamp() . ': ' . "$data:\n";

   # Check for any "weird" characters (10=LF, 13=CR).
   # Note that syslog messages terminated with '\0'?
   my @ord_chars = map {ord} split //, $data;
   my @weird = grep { $_ != 10 && $_ != 13 && ( $_ < 32 || $_ > 126 ) 
+} @ord_chars;
   my $nweird = @weird;
   if (@weird)
   {
      my $s = join "", map { '(' . ( $_ >= 32 && $_ <= 126 ? chr() : "
+" ) . ",ord=$_)" } @ord_chars;

      print "[Recv] $nweird weird ord chars were detected in the previ
+ous line:\n";

      # print "[Recv] $s\n";
      # my $last_ord = $ord_chars[-1];
      # print "[Recv] weird : '@weird' (last_ord='$last_ord')\n";
   }

   return $data;
}

# Note: send_client is not used for (simplex) syslog protocol
sub send_client
{
   my $client = shift;
   my $str    = shift;
   print '[Send] ' . get_datetime_stamp() . ': ' . $str . ":\n";
   print {$client} $str or die "error: print: $!";
}

sub my_log
{
   my $str = shift;
   print '[Info] ' . get_datetime_stamp() . ': ' . $str;
}

sub do_syslog_server
{
   my $host               = shift;
   my $port               = shift;
   my $sleep_after_accept = shift;
   my $sleep_after_recv   = shift;

   my_log( "Start on host '$host' at " . get_datetime_stamp() . "\n" )
+;
   my_log("  pid=$$\n");
   my_log("  port=$port\n");
   my_log("  sleep_after_accept=$sleep_after_accept\n");
   my_log("  sleep_after_recv=$sleep_after_recv\n");

   # This socket is used to listen for connections.
   my $listener = IO::Socket::INET->new(
      LocalPort => $port,
      Proto     => 'tcp',
      Listen    => 5,
      ReuseAddr => 1,
   ) or die "error: IO::Socket::INET new: $@";

   my $selector = IO::Select->new($listener);

SERVER:
   while ( my @ready = $selector->can_read() )
   {
   CLIENT:
      for my $client (@ready)
      {
         if ( $client == $listener )
         {
            my $new_conn = $listener->accept();
            $selector->add($new_conn);
            my $fh_hex = sprintf '0x%x', $new_conn;

            my $peerhost = $new_conn->peerhost();
            my $peerport = $new_conn->peerport();

            my $peeraddr = $new_conn->peeraddr();
            my $peerhostfull = gethostbyaddr( $peeraddr, AF_INET ) || 
+"Cannot resolve";

            my $fromstr = "from $peerhost:$peerport (host=$peerhostful
+l)";

            my_log("Accepted new connection $fromstr\n");
            if ($sleep_after_accept)
            {
               my_log("Sleeping for $sleep_after_accept seconds...\n")
+;
               sleep($sleep_after_accept);
            }
         }
         else
         {
            my $cli_cmd_str = recv_tcp_client($client);
            if ( !defined($cli_cmd_str) )
            {
               my $peerhost = $client->peerhost();
               my $peerport = $client->peerport();
               my_log("Client $peerhost:$peerport closed socket\n");
               $selector->remove($client);
               $client->close();
               next CLIENT;
            }
            if ( $cli_cmd_str =~ /^SERVER_PLEASE_QUIT\s*$/ )
            {
               my_log("Server quitting on your command\n");
               last SERVER;
            }
            if ($sleep_after_recv)
            {
               my_log("Sleeping for $sleep_after_recv seconds...\n");
               sleep($sleep_after_recv);
            }
         }
      }
   }

   my_log("Closing server\n");
   close($listener) or die "error: close server: $!";
   my_log("End do_syslog_server\n");
}

local $| = 1;
my $myhostname = lc( Sys::Hostname::hostname() );

my $port               = 0;    # -p switch
my $sleep_after_accept = 0;    # -a switch
my $sleep_after_recv   = 0;    # -r switch

my %option = ();
Getopt::Std::getopts( "p:a:r:", \%option ) or usage();
usage() if $option{h};
if ( $option{p} )
{
   $port = $option{p};
   $port =~ /^\d+$/ or die "error: invalid -p: '$port'\n";
}
if ( $option{a} )
{
   $sleep_after_accept = $option{a};
   $sleep_after_accept =~ /^\d+$/
      or die "error: invalid -a: '$sleep_after_accept'\n";
}
if ( $option{r} )
{
   $sleep_after_recv = $option{r};
   $sleep_after_recv =~ /^\d+$/
      or die "error: invalid -r: '$sleep_after_recv'\n";
}
usage() if $port <= 0;
usage() if $sleep_after_accept < 0;
usage() if $sleep_after_recv < 0;
@ARGV and usage();

do_syslog_server( $myhostname, $port, $sleep_after_accept, $sleep_afte
+r_recv );

    [download]

    And here is the mock client: 

    # mocksyslogclient.pl.
# Simple test of mocksyslogserver.pl
# Example: perl mocksyslogclient.pl localhost 9949

use strict;
use warnings;
use Socket;
use IO::Socket::INET;

use Getopt::Std ();

# Plain socket version
sub send_tcp_messages
{
   my $host      = shift;
   my $port      = shift;
   my $delaysecs = shift;
   my @messages  = @_;

   $host = inet_aton($host) or die "error: unknown host: $!";
   socket( my $server, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
      or die "error: socket: $!";
   my $dest_addr = sockaddr_in( $port, $host );
   connect( $server, $dest_addr ) or die "error: connect: $!";
   binmode($server);
   $server->autoflush();

   my $nmessages = @messages;
   print "Send $nmessages messages\n";
   my $idx = 0;
   for my $mess (@messages)
   {
      ++$idx;
      print "$idx: send message\n";
      my $nmess = length($mess);
      my $nsent = send( $server, $mess, 0, $dest_addr ) or die "error:
+ send '$mess': $!";
      $nsent == $nmess or die "error: nsent ($nsent != $nmess)";
      print "$idx: sent message ok\n";
      if ( $idx < $nmessages && $delaysecs )
      {
         print "$idx: delay $delaysecs secs\n";
         sleep $delaysecs;
      }
   }

   close($server) or die "error: close: $!";
}

# IO::Socket::INET version
sub send_tcp_messages_inet
{
   my $host      = shift;
   my $port      = shift;
   my $delaysecs = shift;
   my @messages  = @_;

   # Creating object IO::Socket::INET internally creates socket,
   # binds, and connects to TCP server running on port.
   my $server = IO::Socket::INET->new(
      PeerHost => $host,
      PeerPort => $port,
      Proto    => 'tcp',
   ) or die "error: socket new: $@\n";

   my $nmessages = @messages;
   print "Send $nmessages messages\n";
   my $idx = 0;
   for my $mess (@messages)
   {
      ++$idx;
      print "$idx: send message\n";
      my $nmess = length($mess);
      my $nsent = $server->send($mess) or die "error: send '$mess': $!
+";
      $nsent == $nmess or die "error: nsent ($nsent != $nmess)";
      print "$idx: sent message ok\n";
      if ( $idx < $nmessages && $delaysecs )
      {
         print "$idx: delay $delaysecs secs\n";
         sleep $delaysecs;
      }
   }

   $server->close() or die "error: close: $!";
}

sub usage
{
   print <<'DARLING_FASCIST_BULLY_BOY';

A mock syslog client.

usage: mocksyslogclient -h host -p port [-d delaysecs] message...

Examples:
  mocksyslogclient -h localhost -p 9949 "hello"
     Send "hello" message

  mocksyslogclient -h localhost -p 9949 "hello" "there"
     Send two messages

  mocksyslogclient  -h localhost -p 9949 SERVER_PLEASE_QUIT
     Ask server to quit

DARLING_FASCIST_BULLY_BOY
   exit 1;
}

*STDOUT->autoflush();

@ARGV or usage();
my %option = ();
Getopt::Std::getopts( "h:p:d:", \%option ) or usage();

my $host;
if ( $option{h} )
{
   $host = $option{h};
}
$host or die "error: No -h host specified\n";

my $port;
if ( $option{p} )
{
   $port = $option{p};
   $port =~ /^\d+$/ or die "error: invalid -p: '$port'\n";
}

my $delaysecs = 0;
if ( $option{d} )
{
   $delaysecs = $option{d};
   $delaysecs =~ /^\d+$/ or die "error: invalid -d: '$delaysecs'\n";
}
@ARGV or usage();

my @messages = @ARGV;
@messages or die "error: No messages specified\n";

print "host='$host' port='$port' delaysecs='$delaysecs'\n";

# send_tcp_messages_inet( $host, $port, $delaysecs, @messages );
send_tcp_messages( $host, $port, $delaysecs, @messages );

    [download]

    Finally, here is a full example run with one server and two clients.

    Example mock server output: 

    > perl mocksyslogserver.pl -p 9949 -a 3
[Info] 10:24:35: Start on host 'myhost' at 10:24:35
[Info] 10:24:35:   pid=83768
[Info] 10:24:35:   port=9949
[Info] 10:24:35:   sleep_after_accept=3
[Info] 10:24:35:   sleep_after_recv=0
[Info] 10:24:50: Accepted new connection from 127.0.0.1:58683 (host=my
+host)
[Info] 10:24:50: Sleeping for 3 seconds...
[Info] 10:24:53: Accepted new connection from 127.0.0.1:58684 (host=my
+host)
[Info] 10:24:53: Sleeping for 3 seconds...
[Recv] 10:24:56: from 127.0.0.1:58683 read data ok (len=6, null=0)
[Recv] 10:24:56: hello1:
[Recv] 10:24:56: from 127.0.0.1:58683 read hdr eof
[Info] 10:24:57: Client 127.0.0.1:58683 closed socket
[Recv] 10:24:57: from 127.0.0.1:58684 read data ok (len=6, null=0)
[Recv] 10:24:57: hello2:
[Recv] 10:24:57: from 127.0.0.1:58684 read hdr eof
[Info] 10:24:58: Client 127.0.0.1:58684 closed socket
[Info] 10:25:39: Accepted new connection from 127.0.0.1:58695 (host=my
+host)
[Info] 10:25:39: Sleeping for 3 seconds...
[Recv] 10:25:42: from 127.0.0.1:58695 read data ok (len=18, null=0)
[Recv] 10:25:42: SERVER_PLEASE_QUIT:
[Info] 10:25:42: Server quitting on your command
[Info] 10:25:42: Closing server
[Info] 10:25:42: End do_syslog_server
>

    [download]

    Example client 1 output: 

    > perl mocksyslogclient.pl -h localhost -p 9949 "hello1"
host='localhost' port='9949' delaysecs='0'
Send 1 messages
1: send message
1: sent message ok
> perl mocksyslogclient.pl -h localhost -p 9949 "SERVER_PLEASE_QUIT"
host='localhost' port='9949' delaysecs='0'
Send 1 messages
1: send message
1: sent message ok
>

    [download]

    Example client 2 output: 

    > perl mocksyslogclient.pl -h localhost -p 9949 "hello2"
host='localhost' port='9949' delaysecs='0'
Send 1 messages
1: send message
1: sent message ok

    [download]

    See also

    • Effective Automated Testing - the mock syslog server above was used during automated smoke testing of our C functions that wrote Syslog messages; that is why it is easy to start (e.g. perl mocksyslogserver.pl -p 9949 -a 3) and stop (e.g. send it a SERVER_PLEASE_QUIT message) from an autotest script.

    Updated: Added See also section.

[reply]
[d/l]
[select]

Back to Seekers of Perl Wisdom