If you have threads::shared working in a fashion that updates all threads when a new thread is created, properly passing the new socket, I would like to see it and play with it.

Otherwise I have a couple of chat servers using IO::Select or plain select, I could post for you.

Do you have a place to post your whole code? So we can download and test it?

ok, zentara,

here is the whole program. It runs on my pc ;-)

I changed a bit (to be more elegant), but I still left the lines for you
that tells what is going on, just decommand.

Well as far as I remember, sometimes still the Writer is not dieing!!
Therefore I'd like to have its PID to be able to kill the Writer from the Reader.
Is that possible in this construction??


#!/usr/bin/perl


use strict;
use warnings;
use threads;           # pull in threading routines
use threads::shared;   # and variable sharing routines
use IO::Socket::INET;  # and rock the sock et
use File::Temp qw/ :POSIX /;


our @chat:shared = ();
our $Elm:shared = '';
our $NoClient:shared = 0;
our $EOL = "\r\n";
our $kill = 'my Socket broke';

$SIG{PIPE} = 'ignore';   sub ignore { ; }
#We ignore SIGPIPEs generated by clients trying to work
#with closed connections. SIGPIPEs, if not handled, cause death.


    my $server = IO::Socket::INET->new(LocalPort => 3333, 
            Type => SOCK_STREAM,
            Reuse => 1, Listen => 10) or die $!;

    while (my $client = $server->accept()){ 
        my $pAddr = $client->peerhost();
        if ($pAddr!~/^127\.0\.0\./ && $pAddr!~/^10\.10\.10\.\d+/) {
            print $client 'Sorry not for you..',$EOL;
            print "Ooops, who was that? Addr: $pAddr\n";
            close($client);
            next;
        }
        lock($NoClient);
        $NoClient++;
        cond_broadcast($NoClient);
        # create a uniqe ID from tmp-file:
        tmpnam() =~ /.+mp\/(.+)/;
        # initialize the number of lines the Writer for this Client
        lock($Elm);
        $Elm .= "$1:0;";
        cond_broadcast($Elm);
        my $r = threads->new(\&Reader::run, 
            client => $client, "ID","$1");
        $r->detach();                                           
        my $w = threads->new( \&Writer::run, 
            client => $client, "ID", "$1", "Addr" => "$pAddr" );
        $w->detach(); 
    }


#####
package Reader;
use threads;
use threads::shared;

sub new {
    my $pkg = shift;
    my $self = { @_ };
    return bless($self, $pkg);
}
sub run {
    my $self = Reader->new(@_);
    my $socket = $self->{client};
    my $l;

    while(defined ($l = <$socket>) ){
        next if ($NoClient < 2);
        #print "$self->{ID}\t$1\n";
        # skip empty lines
        $l =~ /(.+?)[\n\r]+/;
        if ($1) {
            lock(@chat);
            push @chat, "$self->{ID}\t$1";
            cond_broadcast(@chat);
        }
    } # end while

    lock($NoClient);
    $NoClient--;
    cond_broadcast($NoClient);
    #lock(@chat);
    push @chat, "$self->{ID}\t$kill";
    cond_signal(@chat);

} 


#####
package Writer;
use threads;
use threads::shared;


sub new {
    my $pkg = shift;
    my $self = { @_ };
    return bless($self, $pkg);
}

sub run {
    my $self = Writer->new(@_);
    my $socket = $self->{client};
    my $ID = $self->{ID};
    my $Time = time;
    my %E = ();
    my ($start, $min, $i);
    printf "\t%12s has connected at %s\n",
            $self->{Addr}, scalar(localtime($Time));

    while( "@chat" !~ /$ID\s$kill/ ) {
        lock(@chat);  
        cond_wait(@chat);
    lock($Elm);
    %E = (map { $1 => $2; /(.+):(.+)/ } (split /;/, $Elm));
    #$i =0; print "Writer:  $ID\n\tstart at $E{$ID}, $Elm\n\@chat:\n",
    #        (map {($i++)."\t$_\n"} @chat),"sending:\n";

    for my $i ( $E{$ID} .. $#chat ) {
        $chat[$i] =~ /(.+?)\s(.+)[\n\r]+/;
        print $socket $2,$EOL if ( $1 ne $ID && $2 ne $kill);
        #print "> $i\t$1\t$2\n" if ( $1 ne $ID && $2 ne $kill);
    }
    # now delete from @chat what is not longer needed:
    $E{$ID} = @chat;
    $min = min(values %E);
    #$i = 0; print "\neliminating: $min\n",
    #        (map { ($i++)."\t$_\n"} @chat[0..($min-1)]);
    #$i = 0; print "\nstill kept:\n",
    #        (map {($i++)."\t$_\n"} @chat[$min..$#chat]);

    @chat = @chat[$min .. $#chat];
    #print "\nold Elm: $ID\t$Elm";
    $Elm =''; # to rewrite $E
    foreach ( keys %E) {
        $Elm .= "$_:".(($_ eq $ID) ? @chat : ($E{$_} - $min) ).';';
    }
    #print "\nnew Elm: $ID\t$Elm\n####  done  ####\n\n";
    cond_broadcast($Elm);

    } # end while
   # now eliminate the Writer's ID from $E:
    lock($Elm);
    my @E =  (split /;/, $Elm);
    $Elm =''; # to rewrite $E
    foreach ( @E ) {
        $Elm .= "$_;" unless ( $_ =~ /^$ID\:/);
    }
    cond_broadcast($Elm);
    #print "Writer $$: $ID will die, bye\n";
    printf "\t%12s  disconnected at %s  after %s\n",
        $self->{Addr}, scalar(localtime(time)), s2T(time-$Time);
}

    sub s2T { #: calcs sec into days h:m:s
        if ( $_[0] > 86400 ) {
            my $ti = ( ($_[0]%86400)/3600 )%100;
            my $t = ($_[0]%86400) - ($ti*3600);
            return sprintf(" %i d %3i:%02i:%02i",int($_[0] / 86400),$t
+i,(($t/60)%60),($t-((($t/60)%60)*60)));
        }
        my $ti = ( $_[0]/3600 )%100;
        my $t = $_[0] - ($ti*3600);
        return sprintf("%3i:%02i:%02i",$ti,(($t/60)%60),($t-((($t/60)%
+60)*60)));
    }

    sub min { #: min of value-list
        # @_ =  #: LIST of values (int,float)
        my $m = $_[0];
        foreach (@_) { $m = $_ if $m > $_  }
        return $m; ##: min of list
    }
[download]

Hi, I think I've found the solution.

Eliminate this from the while: @chat" !~ /$ID\s$kill/ and place it right below the cond_wait:


    while( 1 ) {
    lock(@chat);
    cond_wait(@chat);
    last unless ( "@chat" !~ /$ID\s$kill/ );
    lock($Elm);
    ...
[download]


This way even the last 'chatter' deletes his Writer.

But still I don't really understand what is happening,
carl

Useless use of a variable in void context at ./threaded-chat-server li
+ne 120.
Useless use of a variable in void context at ./threaded-chat-server li
+ne 120.

Which is:
%E = ( map { $1 => $2; /(.+):(.+)/ } ( split /;/, $Elm ) );
[download]

I see there are alot of warnings when trying to print to clients, about unitialized values. I tried connecting 3 clients. The server reported the 3 connections, but when I sent something from the clients, it was not printed unless I hit enter twice, but that's minor. More serious: there was no chat-echo back to any client, but the line feeds were echoed if I hit enter repeatedly. So there is a connection and this is promising. So this thing is far from ready to go. If I manage to get it working over the holidays, I'll post it as a snippet. I did observe the problem you are talking about. I start 3 clients and send some messages, Then I kill all clients and then restart them. If I send from client 2 or 3, all goes well; but as soon as I try to send from client1, the whole thing just crashes taking all clients with it. I tried one of these threaded servers before, and didn't get as far as you did, so it looks hopeful. Thanks for posting your code.

zentara,

as I want to exchange results of a program running on several computer
I don't want that the client gets an echo of his own lines. Therefore the ID,
which is added by the Reader

    push @chat, "$self->{ID}\t$1";
[download]

and removed by the Writer and send if $ID ne $1:

    $chat[$i] =~ /(.+?)\s(.+)[\n\r]*/;
    print $socket $2,$EOL if ( $1 ne $ID && $2 ne $kill);
[download]

So the Writer skips the lines with its ID, ok? But this is easy to change!!

The occurence of the warning of the line 120:

    %E = (map { $1 => $2;  /(.+):(.+)/; } (split /;/, $Elm));
[download]

is something that I don't understand!!
This initial warning disappeares if you either remove

 
    /(.+):(.+)/;
[download]

or

    $1 => $2;
[download]

or if you have a seperate function for those two:

    sub _split {
        /(.+):(.+)/;
        return  ($1 => $2) if ($1);
    }
[download]

so that the line 120 looks like

    %E = (map { _split($_)  } (split /;/, $Elm));
[download]


Finally I have to tell you that there is a really, really stupid bug, after the loop of the Writer. This code

    $Elm =''; # to rewrite $E
    foreach ( split /;/, $Elm ) {
        $Elm .= "$_;" unless ( $_ =~ /^$ID\:/);
    }
    cond_broadcast($Elm);
[download]

has to be changed into:

    my $tmp = '';
    foreach ( split /;/, $Elm ) {
        $tmp .= "$_;" if ( $_ !~ /^$ID\:/ && $_ =~/:/);
    }
    $Elm = $tmp;
    cond_broadcast($Elm);
[download]

I think, now everything is ok,
'it can be braodcasted'
Carl

Yeah, I figured out that "no-echo-to-self" part myself, but even with your bug fix, there is no echo, at least on my machine. Linux with Perl5.8.0. Are you using a later Perl version, I know some of Liz's modules require 5.81. I still only get newlines echoed around. As a first guess, I'm thinking it has something to do with your extensive use of $1 and $2, and maybe they are "going out of scope"? I feel confident that I can narrow it down, since I can trace the newlines.

The bigger problem, which I see, is the way the server crashes when you close all clients, then restart them, and try to print something from client 1. It only affects client1.

I have found a fix for this, but it was just by my "intuitive guessing", so I can't say what overall effect it will have. But.......if you don't detach the reader and writer threads, the crash problem goes away.(as far as my limited testing has shown). So comment out:

#  $r->detach(); 
#  $w->detach();
[download]

Maybe that will help your problem. Thanks again for the code. This is the first threaded-chat code I could find.

 for my $i ( $E{$ID} .. $#chat ) {
       $chat[$i] =~ /(.+?)\s(.+)[\n\r]+/;

#       print $socket $2, $EOL if ( $1 ne $ID && $2 ne $kill);
         print $socket $chat[$i], $EOL if ( $1 ne $ID && $2 ne $kill);

       #print "> $i\t$1\t$2\n" if ( $1 ne $ID && $2 ne $kill);
   }
[download]

So I have it working fine to my satisfaction, unless I see something else as I keep testing it. If so I'll let you know.

zentara,

your version

    print $socket $chat[$i], $EOL if ( $1 ne $ID && $2 ne $kill);
[download]

sends the $ID to all the Clients and there it has absolutely no meaning.
The Reader adds the (internal) $ID:

    push @chat, "$self->{ID}\t$1";
[download]

and the Writer should remove this ID:(little changed)

    foreach ( @chat[$E{$ID} .. $#chat] ) {
        # spilt into ID and incomming line
        /(.+?)\s(.+)[\n\r]*/;
        # send only line
        print $socket $2,$EOL if ( $1 ne $ID && $2 ne $kill);
    }
[download]

So a Writer does not send
1. if a line is from its corresponding Reader:   $1 ne $2
2. if a line has the kill-code (no matter by whom):  $2 ne $kill

If you want the Client to get back his own line just change print $socket .. to:

    print $socket $2,$EOL if ( $2 ne $kill );
[download]

Well, when I removed my stupid bug (look at the code,
a few lines above is a simular sitiation, where I can 'empty' $Elm),
this memory access error disappeared. So I think it is from there.

In case of any problem may be you better mail me directly:

    g o o l y @ g m x . a t
[download]

(valid until I get tooo much spam.)

have fun chatting,
carl

" your version

   print $socket $chat[$i], $EOL if ( $1 ne $ID && $2 ne $kill);
[download]

sends the $ID to all the Clients and there it has absolutely no meaning."

Well it's working for me. What I get echoed to all clients is the tmp ID followed by a space, followed by the client message. I find this useful, because it tells me which client originated the message. The following is how I figured it out. I just printed the chatline, and saw the needed info was in there. The chatline I get is a list, the first element is the unique client ID, and the second is the message sent. It isn't split into $1 and $2. Anyways, we both have it working the way each of us likes it best, so it really is no problem.

for my $i ( $E{$ID} .. $#chat ) {
            $chat[$i] =~ /(.+?)\s(.+)[\n\r]+/;

            print "chatline->$chat[$i]\n";
            print "In writerrun \$1->$1  \$2->$2\n";
            print $socket $chat[$i],$EOL; #if ( $1 ne $ID && $2 ne $ki
+ll ); 
#what gets echoed is : Wzghb2n3   foobarfoobarfoobar
[download]

The bigger problem is the threads leaking. You observe it as the first writer not destroying itself. As I mentioned, if you don't detach $r and $w, the server crashing goes away, but there is a thread leak when you kill and restart clients. But it's a clue. I've put the detach back in, and am working on a way of "joining" the threads when they are finished. It only seems that the first thread has this problem, and maybe it has something to do with that line in the reader next if ( $NoClient < 2 ); ? It prevents the last @chat broadcast? Possible?

Sooner or later, I will find a way. I will let you know at your email address what I find. Of course, you may be successful before me, if so post it in the Snippets section. This is nice useful code, which I'm sure is sought after by many newbies. Relatives are arriving today for the holiday parties, so I may be slowed down. :-)