I was bored, so I decided to try to fix your server.
Seems to work fine, I don't see any data-loss in the testing I tried.
#!/usr/bin/perl
# https://perlmonks.org/?node_id=11105232
#!/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 rea
+d
$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 ) )
if( $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";
}