#!/usr/bin/perl
use strict; use warnings;
#tcpserver.pl
use IO::Select;
use IO::Socket;
use Data::Dumper;
use Fcntl;

use constant PORT1 => 5000;
use constant TIMEOUT => 10;
use constant READ_LENGTH => 10; 
# Small to see if "buffer overflow" is handled correctly

my $server_socket =  new IO::Socket::INET(
      Listen => 1, 
      LocalPort => PORT1, 
      ReuseAddr => 1) 
    or die "Can't bind server_socket: $@\n";

my $sel = IO::Select->new;
$sel->add($server_socket);

my %connections; # Infos and Buffers for active connections
my $connID;

while(1)
{
  { # Can be used to limit the number of concurrent connections
    my $n = ( keys %connections ); 
    print "$n acive connections",Dumper(\%connections);
  }
  foreach my $sock (  $sel->can_read(TIMEOUT) ) 
  {
    print "sock:",( defined($connections{$sock}) ? 
      $connections{$sock}{'id'} : 
      ( $sock == $server_socket ? "server" : $sock 
    )),"\n";
    if( $sock == $server_socket ) # New connection
    {
      my $new = $server_socket->accept;
      binmode $new;
      my $flags = fcntl($new,  F_GETFL, 0) or 
          die "[new Err] Can't get flags !$\n";
      fcntl($new , F_SETFL, $flags | O_NONBLOCK ) or 
          die "[new Err] Can't set flags !$\n"; # For nonblocking read

      $sel->add($new);
      $connections{$new} = { 
        ip => $new->peerhost, 
        id => ++$connID, 
        buf => ""
      };
      print "server_socket->new($connections{$new}{'ip'}) Nr:$connecti
+ons{$new}{'id'}\n";
      next;
    }
    my ($rr, $r, $id) = (0, 0, $connections{$sock}{'id'});
    my $buffer = $connections{$sock}{'buf'} ;
    my $buf;
    # $sock needs to be O_NONBLOCK
    while( $rr = sysread($sock,$buf, READ_LENGTH, 0 ) ) 
    { print "[read ", ( $r // "undef" ), " ] '$buf'", "\n";
      if( ! defined( $rr) ) # When does this happen?
      { # Error handler 
        print "[Error $connections{$sock}{'ip'} id: $id]: $!\n";
        # close connections?
        last;
      }
      $buffer .= $buf;
      $r += $rr;
    }
    $connections{$sock}{'buf'} = $buffer;
    print "[Buffer($id)] '$buffer'\n";
    if(0 and $sock->eof ) 
    {
      print "[EOF($id)] ";
      process_message( $sock);
      delete $connections{$sock};
      $sel->remove($sock);
      $sock->close;
      next;
    }
    if ( ! $r )
    {
      print "[empty read($id)]\n";
      process_message( $sock);
      delete $connections{$sock};
      $sel->remove($sock);
      $sock->close;
      next;
    }
  }
}


sub process_message
{
  my ( $sock ) = @_;
  my $filename = "rcv_$connections{$sock}{'id'}".
     "_$connections{$sock}{'ip'}.txt" ;
  open OUT, ">", $filename
    or die "Can not write $filename: $!";
  binmode OUT;
  print OUT $connections{$sock}{'buf'};
  close OUT;
  print "[save process_message] wrote $filename \n";
}
[download]