chat_server.pl

#!/usr/bin/perl

#
## Translation of: https://rosettacode.org/wiki/Chat_server#Python
#

# Create server:
#     perl chat_server.pl

# Connect to the chat via telnet:
#     telnet localhost 4004

use 5.010;
use strict;
use warnings;

use threads;
use threads::shared;

use IO::Socket::INET;
use Time::HiRes qw(sleep ualarm);

my $HOST = "localhost";
my $PORT = 4004;

my @open;
my %users : shared;

sub broadcast {
    my ($id, $message) = @_;
    print "$message\n";
    foreach my $i (keys %users) {
        if ($i != $id) {
            $open[$i]->send("$message\n");
        }
    }
}

sub sign_in {
    my ($conn) = @_;

    state $id = 0;

    threads->new(
        sub {
            while (1) {
                $conn->send("Please enter your name: ");
                $conn->recv(my $name, 1024, 0);

                if (defined $name) {
                    $name = unpack('A*', $name);

                    if (exists $users{$name}) {
                        $conn->send("Name entered is already in use.\n");
                    }
                    elsif ($name ne '') {
                        $users{$id} = $name;
                        broadcast($id, "+++ $name arrived +++");
                        last;
                    }
                }
            }
        }
    );

    ++$id;
    push @open, $conn;
}

my $server = IO::Socket::INET->new(
                                   Timeout   => 0,
                                   LocalPort => $PORT,
                                   Proto     => "tcp",
                                   LocalAddr => $HOST,
                                   Blocking  => 0,
                                   Listen    => 1,
                                   Reuse     => 1,
                                  );

local $| = 1;
print "Listening on $HOST:$PORT\n";

while (1) {
    my ($conn) = $server->accept;

    if (defined($conn)) {
        sign_in($conn);
    }

    foreach my $i (keys %users) {

        my $conn = $open[$i];
        my $message;

        eval {
            local $SIG{ALRM} = sub { die "alarm\n" };
            ualarm(500);
            $conn->recv($message, 1024, 0);
            ualarm(0);
        };

        if ($@ eq "alarm\n") {
            next;
        }

        if (defined($message)) {
            if ($message ne '') {
                $message = unpack('A*', $message);
                broadcast($i, "$users{$i}> $message");
            }
            else {
                broadcast($i, "--- $users{$i} leaves ---");
                delete $users{$i};
                undef $open[$i];
            }
        }
    }

    sleep(0.1);
}