#!/usr/local/bin/perl -w
# tcp-server-ioselect.pl -- Ein Single-threaded-TCP-Server mit select().

# ACHTUNG: Probleme bei IO::Select und fcntl() unter Win95 u. aehnl.

use IO::Socket;
use IO::Select;
use POSIX qw(EWOULDBLOCK);

use constant MYSIZE => 1024;    # Maximale Groesse des Empfangs.
use constant MYPORT => 7123;    # Rendezvous-Port fuer Clients.
use constant POLLME => 1;       # Sekunden pro Lese/Schreibe-Check.
$sock = new IO::Socket::INET(LocalPort => MYPORT,
                     Reuse     => 1,
                     Listen    => 5)
    or die "can't create local socket: $@\n";

# Wir wollen im Aufgabenhash %todo Zeiger als Schluessel zulassen.
use Tie::RefHash;
tie %todo, 'Tie::RefHash' or die "can't tie refhash: $!\n";

# Zunaechst warten wir nur auf unseren Rendezvous-Socket:
deblock($sock);
$sel  = new IO::Select; $sel->add($sock);
print "Ready to accept connections on ", MYPORT, "...\n";

# In einer Endlosschleife:
# 1 .) Alle lesebereiten Sockets nach %in auslesen,
# 1'.) Fertige Auftraege in %in nach %todo transferieren,
# 2 .) Alle Auftraege aus %todo erledigen, nach %out schreiben.
# 3 .) %out-Puffer zu allen schreibbereiten Sockets senden.
while (1) {
    # 1.) Alle lesebereiten Sockets in die %in-Puffer auslesen.
    foreach my $cl ($sel->can_read(POLLME)) {
    if ($cl == $sock) {
        $cl = $sock->accept(); deblock($cl); $sel->add($cl);
        print "Accepted connection from ",
        $cl->peerhost(), ":", $cl->peerport(), "\n";
    } else {
        $nval = $cl->recv($buffer, MYSIZE, 0);
        if (!defined($nval) || !length($buffer)) {
        delete $in{$cl}; delete $out{$cl}; delete $todo{$cl};
        $sel->remove($cl); $cl->close(); next;
        }
        $in{$cl} .= $buffer;
            # 1'.) Fertige Anforderungen (Saetze) in den Arbeitspuffer!
        while ($in{$cl} =~ s/(.*\n)//) { $todo{$cl} .= $1; }
    }
    }

    # 2.) Die Clientanforderungen befriedigen. %out fuellen!
    foreach my $cl (keys %todo) {
    foreach my $line (split(/\n/, $todo{$cl})) {
        $out{$cl} .= scalar(reverse($line)) . "\n";
    }
    delete $todo{$cl};     # Auftrag erledigt!
    }

    # 3.) Die einzelnen Ausgabepuffer zu den bereiten Clients zurueck.
    foreach my $cl ($sel->can_write(POLLME)) {
    next if not exists $out{$cl};  # Kein Ausgabe fuer diesen.
    $nval = $cl->send($out{$cl}, 0);
    if (!defined $nval) { warn "should not happen!\n"; next; }
    if ($nval == length($out{$cl})) {
        # Das Schreiben war erfolgreich, %out loeschen.
        delete $out{$cl};
    } elsif ($nval != 0 and $! == EWOULDBLOCK) {
        # Das Schreiben war nur teilweise erfolgreich.
            # %out verkleinern.
        $out{$cl} = substr($out{$cl}, $nval);
    } else {
        # Irgend etwas anderesist passiert: Client abtrennen.
        delete $in{$cl}; delete $out{$cl}; delete $todo{$cl};
        $sel->remove($cl); $cl->close(); next;
    }
    }
}

# Versetzt ein Handle in den nichtblockierenden Modus:
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
sub deblock {
    my $handle = shift;
    my $flags;

    $flags  = fcntl($handle, F_GETFL, 0)
    or die "can't get fcntl() flags: $!\n";
    $flags |= O_NONBLOCK;  # Diesen zusaetzlich einschalten!
    fcntl($handle, F_SETFL, $flags)
    or die "can't set fcntl() flags: $!\n";
}