#!/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

Well, if you are going to play with it, please kill the client and reconnect several times.
After doing this the chat server suddenly crashes with a memory access error.

Any Ideas?

carl