Simple threaded chat server

[zentara]

I've seen quite a few questions lately about threaded chat servers. Sockets are confusing enough, but when you add threads into it, complete mayhem occurs as newbies mix up IO::Select, threads, and forking. Well, here are 2 very basic snippets for threaded chat. The first is non-echo( it connects to many private single clients). The second is multi-echo-chat. It's only trick is the use of fileno's to share socket filehandles across threads. And finally, a Tk client for testing the servers.

Of course, threaded servers are not better than forking servers, but they can handle big file transfers without blocking( like select). The drawback is the memory footprint will rise and stay at peak usage.

# a private channel server

#!/usr/bin/perl
use warnings;
use strict;
use IO::Socket;
use threads;
$|++;

print $$;

my $server = new IO::Socket::INET(
    Timeout   => 7200,
    Proto     => "tcp",
    LocalPort => 12345,
    Reuse     => 1,
    Listen    => 2
);
my $num_of_client = -1;

while (1) {
    my $client;

    do {
        $client = $server->accept;
    } until ( defined($client) );

    my $peerhost = $client->peerhost();
    print "accepted a client $client, $peerhost, id = ", ++$num_of_cli
+ent, "\n";

     #spawn  a thread here for each client
   my $thr = threads->new( \&processit,$client,$peerhost )->detach(); 

}

sub processit {
     my ($lclient,$lpeer) = @_; #local client
   
     if($lclient->connected){
          # Here you can do your stuff
          # I use have the server talk to the client
          # via print $client and while(<$lclient>)
          print $lclient "$lpeer->Welcome to server\n"; #and 
          #$lclient->recv;
          while(<$lclient>){print $lclient "$lpeer->$_\n"}
        
    }
  
  #close filehandle before detached thread dies out
  close( $lclient);
}
__END__

# slightly modified version of above to add multi-echo-chat

#!/usr/bin/perl
use warnings;
use strict;
use IO::Socket;
use threads;
use threads::shared;
$|++;
print "$$ Server started\n";;  # do a "top -p -H $$" to monitor server
+ threads

our @clients : shared;
@clients = ();

my $server = new IO::Socket::INET(
    Timeout   => 7200,
    Proto     => "tcp",
    LocalPort => 12345,
    Reuse     => 1,
    Listen    => 3
);
my $num_of_client = -1;

while (1) {
    my $client;

    do {
        $client = $server->accept;
    } until ( defined($client) );

    my $peerhost = $client->peerhost();
    print "accepted a client $client, $peerhost, id = ", ++$num_of_cli
+ent, "\n";
    my $fileno = fileno $client;
    push (@clients, $fileno);
    #spawn  a thread here for each client
    my $thr = threads->new( \&processit, $client, $fileno, $peerhost )
+->detach(); 
}
# end of main thread

sub processit {
     my ($lclient,$lfileno,$lpeer) = @_; #local client
        
     if($lclient->connected){
          # Here you can do your stuff
          # I use have the server talk to the client
          # via print $client and while(<$lclient>)
          print $lclient "$lpeer->Welcome to server\n";  
          
          while(<$lclient>){
             # print $lclient "$lpeer->$_\n";
              print "clients-> @clients\n";           
              
              foreach my $fn (@clients) { 
                  open my $fh, ">&=$fn" or warn $! and die;
                  print $fh  "$lpeer->$_"  
                  }
           
           }
        
    }
  
  #close filehandle before detached thread dies out
  close( $lclient);
  #remove multi-echo-clients from echo list
  @clients = grep {$_ !~ $lfileno} @clients;

}
__END__

# and finally a Tk client to test with

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

require Tk::ROText;

#get id
my $name = shift || 'anon';

# create the socket
my $host = 'localhost';
my $port = 12345;

my $socket = IO::Socket::INET->new(
       PeerAddr => $host,
       PeerPort => $port,
       Proto    => 'tcp',
      );

defined $socket or die "ERROR: Can't connect to port $port on $host: $
+!\n";

print STDERR "Connected to server ...\n";

my $mw  = new MainWindow;
my $log = $mw->Scrolled('ROText',
           -scrollbars=>'ose',
           -height=> 5,
           -width=>45,
           -background => 'lightyellow',
           )->pack;

my $txt = $mw->Entry(
          -background=>'white',
          )->pack(-fill=> 'x', -pady=> 5);

$mw ->bind('<Any-Enter>' => sub { $txt->Tk::focus });
$txt->bind('<Return>' => [\&broadcast, $socket]);

$mw ->fileevent($socket, readable => sub {
                    my $line = <$socket>;
                      unless (defined $line) {
                       $mw->fileevent($socket => readable => '');
                       return;
                       }
         $log->insert(end => $line);
         $log->see('end');
  });


MainLoop;

sub broadcast {
    my ($ent, $sock) = @_;

    my $text = $ent->get;
    $ent->delete(qw/0 end/);

    print $sock $name.'->'. $text, "\n";
}
__END__