Chat server implemented in Perl, based on AnyEvent

Event-driven implementation of a chat server, with one main processing thread.

Uses tcp_server method from AnyEvent::Socket for easy creation of a non-blocking TCP connection. Inside the connection callback, the connecting client is informed about other already connected clients and client information (host:port identifier and the client socket handle) is stored in a hash. The client file/socket handle, available in the tcp_server callback after a client connects to the server, is wrapped in a AnyEvent::Handle object to allow event-driven access and manipulation. The on_read handler of the client socket handle deals with the client message, sending it to all other connecting servers. The client can send a message either directly, or first send OK, followed by the message itself. 

#!/usr/bin/perl

 
=head2 chat_server.pl

Perl chat server based on AnyEvent

Server:     perl $0
Clients:    telnet 127.0.0.1 8888 (run in several terminals)
            clients communicate by:
                                    a) sending message terninated with carriage return
                                    b) sending OK, followed by carriage return
                                       sending  message terninated with carriage return  

=cut

use strict;
use warnings;
use utf8;
use v5.018;

use AnyEvent;                           # creates event driven loop
use AnyEvent::Socket qw(tcp_server);    # provides high level function to create tcp server
use AnyEvent::Handle;                   # creates non-blocking (socket) handle

use Data::Dumper qw(Dumper);

sub _inform_clients;

=head2 Store connected clients in a hash structure

key:    $host:$port ..... uniquely identifies a connected client
value:  socket handle ... so we can continue communication with individual clients

=cut

my %client = ();

=head2 Create TCP server

allow connection from everywhere, on a specified port

=cut

tcp_server undef, 8888, sub {
    my ($fh, $host, $port) = @_;

    say "[$host:$port] connected";

=head3 On connection, tell the client how many are already connected

=cut

    syswrite $fh, "Hello friend. There are currently " . scalar(keys %client) . 
                  " connected friends.\015\012";

    _inform_clients(\%client, "Friend [$host:$port] joined us!");

=head3 Create nonblocking socket handle for the client

=cut

    my $hdl = AnyEvent::Handle->new(
        fh => $fh,
    );

=head3 Store client information

=cut

    my $client_key = "$host:$port";
    $client{$client_key} = $hdl;

=head3 On error, clear the read buffer

=cut

    $hdl->on_error (sub {
        my $data = delete $_[0]{rbuf};
    });

=head3 On receiving a message from a client

We expect:

    sending a regular message
        either "OK\n", then a message
        or      directly a message
    disconnecting
        send quit/QUIT followed by carriage return

=cut

    my $writer; 
    $writer = sub {
        my ($hdl, $line) = @_;
        say "Reading from client: [$line]";

        my @clients = keys %client;
        say Dumper(\@clients);

        # The client cannot disconnect until we release its handle
        if ($line =~ /\Aquit|bye|exit\z/i) {

            my $client_count = (scalar keys %client) - 1;       # exclude the leaving client
            say "REMAINING (apart from this): $client_count";

            # Send message to each client
            for my $key (@clients) {

                if ($key eq $client_key) {
                    $hdl->push_write("Bye\015\012");
                }
                else {
                    my $message = ($client_count > 1) ? "only $client_count of us left\015\012" : 
                                                         "You are the only one left :(. Send quit/QUIT to disconnect\015\012";
                    $client{$key}->push_write("Friend $client_key is leaving us, $message");
                }

            }

            $hdl->push_shutdown;
            delete $client{$client_key};
            
        }
        # if we got an "OK", we have to _prepend_ another line,
        # so it will be read before the second request reads the 64 bytes ("OK\n")
        # which are already stored in the queue when this callback is called
        elsif ($line eq "OK") {
            $_[0]->unshift_read (line => sub {
                my $response = $_[1];
                for my $key (grep {$_ ne $client_key} @clients) {
                    $client{$key}->push_write("$response from $client_key\015\012");
                }
            });
        }
        elsif ($line) {
            for my $key (grep {$_ ne $client_key} @clients) {
                my $response = $line;
                $client{$key}->push_write("$response from $client_key\015\012");
            }
        }
    };

=head3  Enter the request handling loop

=cut

    $hdl->on_read (sub {
        my ($hdl) = @_;

        # Read what was sent, when request/message received
        # (then distribute the message)
        $hdl->push_read (line => $writer);
    });

};

=head3 Start the event loop

=cut

AnyEvent->condvar->recv; 

=head2 SUBROUTINES

_inform_clients

=cut

=head2 _inform_clients

sends a message to all known/stored clients

=cut

sub _inform_clients {
    my ($client_href, $message) = @_;

    for my $key (keys %$client_href) {
        $client{$key}->push_write("$message\015\012");
    }
}

Source code on github