server-cooperative.pl

#!/usr/bin/perl
use warnings;
use strict;

use AnyEvent;
use AnyEvent::Socket;
use Coro;
use Coro::Handle;

my %open;

tcp_server undef, 7377, sub {
    my ($fh) = @_;
    $fh = unblock($fh);
    $open{$fh} = $fh; # keep track of it

    async {
        eval { # trap errors
            while ( 1 ) {
                my $line = $fh->readline;
                last if not defined $line;

                for my $open ( values %open ) {
                    if ( $open != $fh ) {
                        print $open $line;
                    }
                }
            }
        };

        warn $@ if $@;

        delete $open{$fh};
    };
};

AnyEvent->condvar->recv; # wait forever

server-traditional.pl

#!/usr/bin/perl
use warnings;
use strict;

use IO::Select;
use IO::Handle;
use IO::Socket::INET;

my $listen = IO::Socket::INET->new(
    LocalPort => 7377,
    Listen => 4,
);

my $read = IO::Select->new($listen);
my $write = IO::Select->new();
my $except = IO::Select->new();

my %bufs;

sub drop {
    my ($fh) = @_;
    $read->remove($fh);
    $write->remove($fh);
    $except->remove($fh);
    delete $bufs{$fh};
}

while ( 1 ) {
    my ($read_rdy, $write_rdy, $except_rdy) = IO::Select->select($read, $write, $except);

    for my $fh ( @$read_rdy ) {
        if ( $fh == $listen ) {
            my $new = $listen->accept;
            $read->add($new);
        } else {
            my $buf;
            my $len = sysread($fh, $buf, 1024);

            if ( not $len ) {
                # eof
                drop $fh;
                next;
            }

            for my $h ( $read->handles ) {
                next if $h == $listen;
                next if $h == $fh;
                $bufs{$h} .= $buf;
                $write->add($h);
            }
        }
    }

    for my $fh ( @$write_rdy ) {
        my $len = syswrite($fh, $bufs{$fh});
        substr($bufs{$fh}, 0, $len, '');

        if ( not $len ) {
            # couldn't write to the socket when it was said that it was writable to
            # wtf
            drop $fh;
            next;
        }

        if ( not length $bufs{$fh} ) {
            delete $bufs{$fh};
            $write->remove($fh);
        }
    }

    for my $fh ( @$except_rdy ) {
        print "exception on $fh, dropping it\n";
        drop $fh;
    }
}