comment on

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__
[download]

# 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__
[download]

# 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__
[download]

In reply to Simple threaded chat server by zentara

Are you posting in the right place? Check out Where do I post X? to know for sure.
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
Want more info? How to link or How to display code and escape characters are good places to start.


Perl: the Markov chain saw
	PerlMonks