File Coverage

blib/lib/Net/Clacks/Server.pm

Criterion	Covered	Total	%
statement	85	874	9.7
branch	0	368	0.0
condition	0	121	0.0
subroutine	28	44	63.6
pod	4	9	44.4
total	117	1416	8.2

package Net::Clacks::Server;
#---AUTOPRAGMASTART---
use 5.020;
use strict;
use warnings;
use diagnostics;
use mro 'c3';
use English;
use Carp;
our $VERSION = 23;
use autodie qw( close );
use Array::Contains;
use utf8;
use Encode qw(is_utf8 encode_utf8 decode_utf8);
use feature 'signatures';
no warnings qw(experimental::signatures);
#---AUTOPRAGMAEND---

use XML::Simple;
use Time::HiRes qw(sleep usleep time);
use Sys::Hostname;
use Errno;
use IO::Socket::IP;
use IO::Select;
use IO::Socket::SSL;
use YAML::Syck;
use MIME::Base64;
use File::Copy;
use Data::Dumper;

# For turning off SSL session cache
use Readonly;
Readonly my $SSL_SESS_CACHE_OFF => 0x0000;

my %overheadflags = (
    A => "auth_token", # Authentication token
    O => "auth_ok", # Authentication OK
    F => "auth_failed", # Authentication FAILED

    E => 'error_message', # Server to client error message

    C => "close_all_connections",
    D => "discard_message",
    G => "forward_message",
    I => "set_interclacks_mode", # value: true/false, disables 'G' and 'U'
    L => "lock_for_sync", # value: true/false, only available in interclacks client mode
    M => "informal_message", # informal message, no further operation on it
    N => "no_logging",
    S => "shutdown_service", # value: positive number (number in seconds before shutdown). If interclacks clients are present, should be high
                             # enough to flush all buffers to them

    T => 'timestamp',        # Used before KEYSYNC to compensate for time drift between different systems
    U => "return_to_sender",
    Z => "no_flags", # Only sent when no other flags are set
);

BEGIN {
    {
        # We need to add some extra function to IO::Socket::SSL so we can track the client ID
        # on both TCP and Unix Domain Sockets
        no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
        *{"IO::Socket::SSL::_setClientID"} = sub {
            my ($self, $cid) = @_;

            ${*$self}{'__client_id'} = $cid; ## no critic (References::ProhibitDoubleSigils)
            return;
        };

        *{"IO::Socket::SSL::_getClientID"} = sub {
            my ($self) = @_;

            return ${*$self}{'__client_id'} || ''; ## no critic (References::ProhibitDoubleSigils)
        };

    }

}

sub new($class, $isDebugging, $configfile) {

    my $self = bless {}, $class;

    $self->{isDebugging} = $isDebugging;
    $self->{configfile} = $configfile;

    $self->{timeoffset} = 0;

    if(defined($ENV{CLACKS_SIMULATED_TIME_OFFSET})) {
        $self->{timeoffset} = 0 + $ENV{CLACKS_SIMULATED_TIME_OFFSET};
        print "****** RUNNING WITH A SIMULATED TIME OFFSET OF ", $self->{timeoffset}, " seconds ******\n";
    }

    $self->{clackscache} = {};
    $self->{clackscachetime} = {};
    $self->{clackscacheaccesstime} = {};

    return $self;
}

sub init($self) {

    my @paths;
    if(defined($ENV{'PC_CONFIG_PATHS'})) {
        push @paths, split/\:/, $ENV{'PC_CONFIG_PATHS'};
        print "Found config paths:\n", Dumper(\@paths), " \n";
    } else {
        print("PC_CONFIG_PATHS undefined, falling back to legacy mode\n");
        @paths = ('', 'configs/');
    }

    my $filedata;
    my $fname = $self->{configfile};
    foreach my $path (@paths) {
        if($path ne '' && $path !~ /\/$/) {
            $path .= '/';
        }
        my $fullfname = $path . $fname;
        next unless (-f $fullfname);
        print "   Loading config file $fullfname\n";

        $filedata = slurpBinFile($fullfname);

        foreach my $varname (keys %ENV) {
            next unless $varname =~ /^PC\_/;

            my $newval = $ENV{$varname};
            $filedata =~ s/$varname/$newval/g;
        }

        last;
    }

    if(!defined($filedata) || $filedata eq "") {
        croak("Can't load config file: Not found or empty!");
    }

    print "------- Parsing config file $fname ------\n";
    my $config = XMLin($filedata, ForceArray => [ 'ip', 'socket' ]);

    my $hname = hostname;

    # Copy hostname-specific stuff to root if it exists
    if(defined($config->{hosts}->{$hname})) {
        foreach my $key (keys %{$config->{hosts}->{$hname}}) {
            $config->{$key} = $config->{hosts}->{$hname}->{$key};
        }
    }

    $self->{config} = $config;

    if(!defined($self->{config}->{throttle}->{maxsleep})) {
        $self->{config}->{throttle}->{maxsleep} = 100;
    }
    if(!defined($self->{config}->{throttle}->{step})) {
        $self->{config}->{throttle}->{step} = 10;
    }

    $self->{usleep} = 0;

    if(!defined($self->{config}->{ssl}) ||
            !defined($self->{config}->{ssl}->{cert}) ||
            !defined($self->{config}->{ssl}->{key})) {
        croak("Missing or incomplete SSL config!");
    }
    if(!-f $self->{config}->{ssl}->{cert}) {
        croak("SSL cert file " . $self->{config}->{ssl}->{cert} . " not found!");
    }
    if(!-f $self->{config}->{ssl}->{key}) {
        croak("SSL key file " . $self->{config}->{ssl}->{key} . " not found!");
    }

    if(!defined($self->{config}->{username})) {
        croak("Username not defined!");
    }
    if(!defined($self->{config}->{password})) {
        croak("Password not defined!");
    }
    $self->{authtoken} = encode_base64($self->{config}->{username}, '') . ':' . encode_base64($self->{config}->{password}, '');

    if(defined($self->{config}->{persistancefile})) {
        $self->{persistance} = 1;
    } else {
        $self->{persistance} = 0;
    }

    if(!defined($self->{config}->{persistanceinterval})) {
        $self->{persistanceinterval} = 10;
    } else {
        $self->{persistanceinterval} = $self->{config}->{persistanceinterval};
    }

    if(!defined($self->{config}->{interclacksreconnecttimeout})) {
        $self->{config}->{interclacksreconnecttimeout} = 30;
    }

    if(!defined($self->{config}->{authtimeout})) {
        $self->{config}->{authtimeout} = 15;
    }

    if(!defined($self->{config}->{deletedcachetime})) {
        $self->{config}->{deletedcachetime} = 60 * 60; # 1 hour
    }
    if(!defined($self->{config}->{stalecachetime})) {
        $self->{config}->{stalecachetime} = 60 * 60 * 24; # 1 day
    }

    my @tcpsockets;

    if(defined($config->{ip})) {
        if(!defined($config->{port})) {
            croak("At least one IP defined, but no TCP port!");
        }
        foreach my $ip (@{$config->{ip}}) {
            my $tcp = IO::Socket::IP->new(
                LocalHost => $ip,
                LocalPort => $config->{port},
                Listen => 1,
                Blocking => 0,
                ReuseAddr => 1,
                Proto => 'tcp',
            ) or croak($ERRNO);
            #binmode($tcp, ':bytes');
            push @tcpsockets, $tcp;
            print "Listening on $ip:", $config->{port}, "/tcp\n";
        }
    }

    if(defined($config->{socket}) || defined($self->{config}->{master}->{socket})) {
        my $udsloaded = 0;
        eval { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
            require IO::Socket::UNIX;
            $udsloaded = 1;
        };
        if(!$udsloaded) {
            croak("Specified a unix domain socket, but i couldn't load IO::Socket::UNIX!");
        }

        # Add the ClientID stuff to Unix domain sockets as well. We don't do this in the BEGIN{} block
        # since we are not yet sure we are going to load IO::Socket::UNIX in the first place
        {
            no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
            *{"IO::Socket::UNIX::_setClientID"} = sub {
                my ($self, $cid) = @_;

                ${*$self}{'__client_id'} = $cid; ## no critic (References::ProhibitDoubleSigils)
                return;
            };

            *{"IO::Socket::UNIX::_getClientID"} = sub {
                my ($self) = @_;

                return ${*$self}{'__client_id'} || ''; ## no critic (References::ProhibitDoubleSigils)
            };
        }
    }

    if(defined($config->{socket})) {
        foreach my $socket (@{$config->{socket}}) {
            if(-S $socket) {
                print "Removing old unix domain socket file $socket\n";
                unlink $socket;
            }
            my $tcp = IO::Socket::UNIX->new(
                Type => SOCK_STREAM(),
                Local => $socket,
                Listen => 1,
                #Blocking => 0,
            ) or croak($ERRNO);
            $tcp->blocking(0);
            #binmode($tcp, ':bytes');
            push @tcpsockets, $tcp;
            print "Listening on Unix domain socket $socket\n";

            if(defined($config->{socketchmod}) && $config->{socketchmod} ne '') {
                my $cmd = 'chmod ' . $config->{socketchmod} . ' ' . $socket;
                print $cmd, "\n";
                `$cmd`;
            }
        }
    }

    $self->{tcpsockets} = \@tcpsockets;


    print "Ready.\n";


    return;
}

sub loadPersistanceFile($self, $fname) {
    my %clackscache;
    my %clackscachetime;
    my %clackscacheaccesstime;

    if(open(my $ifh, '<', $fname)) {
        my $line = <$ifh>;
        my $timestampline = <$ifh>;
        my $accesstimeline = <$ifh>;
        my $endline = <$ifh>;
        my $needupgrade = 0;
        close $ifh;

        chomp $line;
        chomp $timestampline;
        chomp $accesstimeline;

        if(!defined($endline) && $accesstimeline eq 'ENDBYTES') {
            $endline = 'ENDBYTES';
            $accesstimeline = '';
            $needupgrade = 1;
        } else {
            chomp $endline;
        }

        if(!defined($line) || !defined($timestampline) || $endline ne 'ENDBYTES') {
            carp("Invalid persistance file " . $fname . "! File is incomplete!");
            return; # Fail
        }

        my $loadok = 0;

        if($line ne '') {
            eval {
                $line = decode_base64($line);
                $line = Load($line);
                $loadok = 1;
            };
            if(!$loadok) {
                carp("Invalid persistance file " . $fname . "! Failed to decode data line!");
                return; # Fail
            }
        }
        %clackscache = %{$line};

        # Mark all data as current as a fallback
        my $now = $self->getTime();
        foreach my $key (keys %clackscache) {
            $clackscachetime{$key} = $now;
        }

        if($timestampline ne '') {
            $loadok = 0;
            eval {
                $timestampline = decode_base64($timestampline);
                $timestampline = Load($timestampline);
                $loadok = 1;
            };
            if(!$loadok) {
                carp("Invalid persistance file " . $fname . "! Failed to decode timestamp line, using current time!");
                return; # Fail
            } else {
                my %clackstemp = %{$timestampline};
                foreach my $key (keys %clackstemp) {
                    $clackscachetime{$key} = $clackstemp{$key};
                }
            }
        }

        if($needupgrade) {
            print "Pre-Version 22 persistance file detected. Upgrading automatically.\n";
            foreach my $key (keys %clackscache) {
                $clackscacheaccesstime{$key} = $now;
            }
        } elsif($accesstimeline ne '') {
            $loadok = 0;
            eval {
                $accesstimeline = decode_base64($accesstimeline);
                $accesstimeline = Load($accesstimeline);
                $loadok = 1;
            };
            if(!$loadok) {
                carp("Invalid persistance file " . $fname . "! Failed to decode timestamp line, using current time!");
                return; # Fail
            } else {
                %clackscacheaccesstime = %{$accesstimeline};
            }
        }
    } else {
        # Fail
        return;
    }

    return \%clackscache, \%clackscachetime, \%clackscacheaccesstime;
}


sub run($self) { ## no critic (Subroutines::ProhibitExcessComplexity)
    my $savecache = 0;
    my $lastsavecache = 0;

    # Let STDOUT/STDERR settle down first
    sleep(0.1);

    # Need to ignore SIGPIPE, this can screw us over in certain circumstances
    # while writing to the network. We can only detect certain types of disconnects
    # after writing to the socket, but we will get a SIGPIPE if we try. So we just
    # ignore the signal and carry on as usual...
    $SIG{PIPE} = 'IGNORE';

    my @toremove;
    my @outbox;
    my %clients;

    my $shutdowntime;
    my $selector = IO::Select->new();
    my $interclackslock = 0;
    my $nextinterclackscheck = 0;

    my $keepRunning = 1;
    $SIG{INT} = sub { $keepRunning = 0; };
    $SIG{TERM} = sub { $keepRunning = 0; };

    # Restore persistance file if required
    if($self->{persistance}) {
        my $previousfname = $self->{config}->{persistancefile} . '_bck';
        my $tempfname = $self->{config}->{persistancefile} . '_';
        my $loadok = 0;
        if(-f $self->{config}->{persistancefile}) {
            print "Trying to load persistance file ", $self->{config}->{persistancefile}, "\n";
            my ($cc, $cct, $cca) = $self->loadPersistanceFile($self->{config}->{persistancefile});
            if(defined($cc) && ref $cc eq 'HASH') {
                $self->{clackscache} = $cc;
                $self->{clackscachetime} = $cct;
                $self->{clackscacheaccesstime} = $cca;
                $savecache = 1; # Force saving a new persistance file
                $loadok = 1;
            }
        }

        if(!$loadok && -f $previousfname) {
            print "Trying to load backup (previous) persistance file ", $previousfname, "\n";
            my ($cc, $cct, $cca) = $self->loadPersistanceFile($previousfname);
            if(defined($cc) && ref $cc eq 'HASH') {
                $self->{clackscache} = $cc;
                $self->{clackscachetime} = $cct;
                $self->{clackscacheaccesstime} = $cca;
                $savecache = 2; # Force saving a new persistance file plus a new backup
                $loadok = 1;
            }
        }
        if(!$loadok && -f $tempfname) {
            print "Oh no. As a final, desperate solution, trying to load a 'temporary file while saving' persistance file ", $tempfname, "\n";
            my ($cc, $cct, $cca) = $self->loadPersistanceFile($tempfname);
            if(defined($cc) && ref $cc eq 'HASH') {
                $self->{clackscache} = $cc;
                $self->{clackscachetime} = $cct;
                $self->{clackscacheaccesstime} = $cca;
                $savecache = 2; # Force saving a new persistance file plus a new backup
                $loadok = 1;
            }
        }

        if(!$loadok) {
            print "Sorry, no valid persistance file found. Starting server 'blankety-blank'\n";
            $savecache = 2;
        } else {
            print "Persistance file loaded\n";
        }
    }

    while($keepRunning) {
        my $workCount = 0;

        # Check for shutdown time
        if($shutdowntime && $shutdowntime < time) {
            print STDERR "Shutdown time has arrived!\n";
            $keepRunning = 0;
        }

        my $now = $self->getTime();
        if($savecache && $now > ($lastsavecache + $self->{persistanceinterval})) {
            $lastsavecache = $now;
            $self->savePersistanceFile($savecache);
            $savecache = 0;
        }

        # We are in client mode. We need to add an interclacks link
        if(defined($self->{config}->{master}->{socket}) || defined($self->{config}->{master}->{ip})) {
            my $mcid;
            if(defined($self->{config}->{master}->{socket})) {
                $mcid = 'unixdomainsocket:interclacksmaster';
            } else {
                $mcid = $self->{config}->{master}->{ip}->[0] . ':' . $self->{config}->{master}->{port};
            }
            if(!defined($clients{$mcid}) && $nextinterclackscheck < $now) {
                $nextinterclackscheck = $now + $self->{config}->{interclacksreconnecttimeout} + int(rand(10));

                print "Connect to master\n";
                my $msocket;

                if(defined($self->{config}->{master}->{socket})) {
                    $msocket = IO::Socket::UNIX->new(
                        Peer => $self->{config}->{master}->{socket}->[0],
                        Type => SOCK_STREAM,
                    );
                } else {
                    $msocket = IO::Socket::IP->new(
                        PeerHost => $self->{config}->{master}->{ip}->[0],
                        PeerPort => $self->{config}->{master}->{port},
                        Type => SOCK_STREAM,
                        Timeout => 5,
                    );
                }
                if(!defined($msocket)) {
                    print STDERR "Can't connect to MASTER via interclacks!\n";
                } else {
                    print "connected to master\n";

                    if(ref $msocket ne 'IO::Socket::UNIX') {
                        # ONLY USE SSL WHEN RUNNING OVER THE NETWORK
                        # There is simply no point in running it over a local socket.
                        my $encrypted = IO::Socket::SSL->start_SSL($msocket,
                                                                   SSL_verify_mode => SSL_VERIFY_NONE,
                        );
                        if(!$encrypted) {
                            print "startSSL failed: ", $SSL_ERROR, "\n";
                            next;
                        }
                    }

                    $msocket->blocking(0);
                    #binmode($msocket, ':bytes');
                    my %tmp = (
                        buffer  => '',
                        charbuffer => [],
                        listening => {},
                        socket => $msocket,
                        lastping => $now,
                        mirror => 0,
                        outbuffer => "CLACKS PageCamel $VERSION in interclacks client mode\r\n" .  # Tell the server we are using PageCamel Interclacks...
                                     "OVERHEAD A " . $self->{authtoken} . "\r\n" .              # ...send Auth token
                                     "OVERHEAD I 1\r\n",                                        # ...and turn interclacks master mode ON on remote side
                        clientinfo => 'Interclacks link',
                        client_timeoffset => 0,
                        interclacks => 1,
                        interclacksclient => 1,
                        lastinterclacksping => $now,
                        lastmessage => $now,
                        authtimeout => $now + $self->{config}->{authtimeout},
                        authok => 0,
                        failcount => 0,
                        outmessages => [],
                        inmessages => [],
                        messagedelay => 0,
                        inmessagedelay => 0,
                        outmessagedelay => 0,
                    );

                    if(defined($self->{config}->{master}->{ip})) {
                        $tmp{host} = $self->{config}->{master}->{ip}->[0];
                        $tmp{port} = $self->{config}->{master}->{port};
                    }
                    $clients{$mcid} = \%tmp;
                    $msocket->_setClientID($mcid);
                    $selector->add($msocket);

                    $workCount++;
                }
            }
        }

        foreach my $tcpsocket (@{$self->{tcpsockets}}) {
            my $clientsocket = $tcpsocket->accept;
            if(defined($clientsocket)) {
                $clientsocket->blocking(0);
                my ($cid, $chost, $cport);
                if(ref $tcpsocket eq 'IO::Socket::UNIX') {
                    $chost = 'unixdomainsocket';
                    $cport = $now . ':' . int(rand(1_000_000));
                } else {
                    ($chost, $cport) = ($clientsocket->peerhost, $clientsocket->peerport);
                }
                print "Got a new client $chost:$cport!\n";
                $cid = "$chost:$cport";
                foreach my $debugcid (keys %clients) {
                    if($clients{$debugcid}->{mirror}) {
                        $clients{$debugcid}->{outbuffer} .= "DEBUG CONNECTED=" . $cid . "\r\n";
                    }
                }

                if(ref $clientsocket ne 'IO::Socket::UNIX') {
                    # ONLY USE SSL WHEN RUNNING OVER THE NETWORK
                    # There is simply no point in running it over a local socket.
                    my $encrypted = IO::Socket::SSL->start_SSL($clientsocket,
                                                               SSL_server => 1,
                                                               SSL_cert_file => $self->{config}->{ssl}->{cert},
                                                               SSL_key_file => $self->{config}->{ssl}->{key},
                                                               SSL_cipher_list => 'ALL:!ADH:!RC4:+HIGH:+MEDIUM:!LOW:!SSLv2:!SSLv3!EXPORT',
                                                               SSL_create_ctx_callback => sub {
                                                                    my $ctx = shift;

                                                                    # Enable workarounds for broken clients
                                                                    Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL); ## no critic (Subroutines::ProhibitAmpersandSigils)

                                                                    # Disable session resumption completely
                                                                    Net::SSLeay::CTX_set_session_cache_mode($ctx, $SSL_SESS_CACHE_OFF);

                                                                    # Disable session tickets
                                                                    Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_NO_TICKET); ## no critic (Subroutines::ProhibitAmpersandSigils)
                                                                },
                    );
                    if(!$encrypted) {
                        print "startSSL failed: ", $SSL_ERROR, "\n";
                        next;
                    }
                }

                $clientsocket->blocking(0);
                #binmode($clientsocket, ':bytes');
                #$clientsocket->{clacks_cid} = $cid;
                my %tmp = (
                    buffer  => '',
                    charbuffer => [],
                    listening => {},
                    socket => $clientsocket,
                    lastping => $now,
                    mirror => 0,
                    outbuffer => "CLACKS PageCamel $VERSION\r\n" .
                                 "OVERHEAD M Authentication required\r\n",  # Informal message
                    clientinfo => 'UNKNOWN',
                    client_timeoffset => 0,
                    host => $chost,
                    port => $cport,
                    interclacks => 0,
                    interclacksclient => 0,
                    lastinterclacksping => 0,
                    lastmessage => $now,
                    authtimeout => $now + $self->{config}->{authtimeout},
                    authok => 0,
                    failcount => 0,
                    outmessages => [],
                    inmessages => [],
                    inmessagedelay => 0,
                    outmessagedelay => 0,
                );
                if(0 && $self->{isDebugging}) {
                    $tmp{authok} = 1;
                    $tmp{outbuffer} .= "OVERHEAD M debugmode_auth_not_really_required\r\n"
                }
                $clients{$cid} = \%tmp;
                $clientsocket->_setClientID($cid);
                $selector->add($clientsocket);
                $workCount++;
            }
        }

        # Check if there are any clients to disconnect...

        my $pingtime = $now - $self->{config}->{pingtimeout};
        my $interclackspingtime = $now - $self->{config}->{interclackspingtimeout};
        my $interclackspinginterval = $now - int($self->{config}->{interclackspingtimeout} / 3);
        foreach my $cid (keys %clients) {
            if(!$clients{$cid}->{socket}->connected) {
                push @toremove, $cid;
                next;
            }
            if(!$clients{$cid}->{interclacks}) {
                if($clients{$cid}->{lastping} > 0 && $clients{$cid}->{lastping} < $pingtime) {
                    $self->evalsyswrite($clients{$cid}->{socket}, "\r\nTIMEOUT\r\n");
                    push @toremove, $cid;
                    next;
                }
            } else {
                if($clients{$cid}->{lastping} < $interclackspingtime) {
                    $self->evalsyswrite($clients{$cid}->{socket}, "\r\nTIMEOUT\r\n");
                    push @toremove, $cid;
                    next;
                }
            }

            if($clients{$cid}->{interclacks} && $clients{$cid}->{lastinterclacksping} < $interclackspinginterval) {
                $clients{$cid}->{lastinterclacksping} = $now;
                $clients{$cid}->{outbuffer} .= "PING\r\n";
            }

            if(!$clients{$cid}->{authok} && $clients{$cid}->{authtimeout} < $now) {
                # Authentication timeout!
                push @toremove, $cid;
            }
        }

        # ...and disconnect them
        while((my $cid = shift @toremove)) {
            # In some circumstances, there may be multiple @toremove entries for the same client. Ignore them...
            if(defined($clients{$cid})) {
                print "Removing client $cid\n";
                foreach my $debugcid (keys %clients) {
                    if($clients{$debugcid}->{mirror}) {
                        $clients{$debugcid}->{outbuffer} .= "DEBUG DISCONNECTED=" . $cid . "\r\n";
                    }
                }

                if($clients{$cid}->{interclacksclient} && $interclackslock) {
                    print "...this one is interclacks master and has us locked - UNLOCKING mid-sync!\n";
                    $interclackslock = 0;
                }

                $selector->remove($clients{$cid}->{socket});
                delete $clients{$cid};
            }

            $workCount++;
        }

        if(!(scalar keys %clients)) {
            # No clients to handle, let's sleep and try again later
            sleep(0.1);
            next;
        }


        my $hasoutbufferwork = 0;
        foreach my $cid (keys %clients) {
            if(length($clients{$cid}->{buffer}) > 0) {
                # Found some work to do
                $hasoutbufferwork = 1;
                last;
            }
        }
        my $selecttimeout = 0.5; # Half a second
        if($hasoutbufferwork) {
            $selecttimeout = 0.05;
        }

        my @inclients = $selector->can_read($selecttimeout);
        foreach my $clientsocket (@inclients) {
            my $cid = $clientsocket->_getClientID();

            my $totalread = 0;
            my $readchunksleft = 3;
            while(1) {
                my $rawbuffer;
                my $readok = 0;
                eval {
                    sysread($clients{$cid}->{socket}, $rawbuffer, 1_000_000); # Read at most 1 Meg at a time
                    $readok = 1;
                };
                if(!$readok) {
                    push @toremove, $cid;
                    last;
                }
                if(defined($rawbuffer) && length($rawbuffer)) {
                    $totalread += length($rawbuffer);
                    push @{$clients{$cid}->{charbuffer}}, split//, $rawbuffer;
                    $readchunksleft--;
                    if(!$readchunksleft) {
                        last;
                    }
                    next;
                }
                last;
            }

            # Check if we could read data from a socket that was marked as readable.
            # Thanks to SSL, this might ocxasionally fail. Don't bail out at the first
            # error, only if multiple happen one after the other
            if($totalread) {
                $clients{$cid}->{failcount} = 0;
            } else {
                $clients{$cid}->{failcount}++;

                if($clients{$cid}->{failcount} > 5) {
                    # Socket was active multiple times but delivered no data?
                    # EOF, maybe, possible, perhaps?
                    push @toremove, $cid;
                }
            }
        }

        foreach my $cid (keys %clients) {
            while(@{$clients{$cid}->{charbuffer}}) {
                my $buf = shift @{$clients{$cid}->{charbuffer}};

                $workCount++;
                if($buf eq "\r") {
                    next;
                } elsif($buf eq "\n") {
                    next if($clients{$cid}->{buffer} eq ''); # Empty lines

                    my %inmsg = (
                        message => $clients{$cid}->{buffer},
                        releasetime => $now + $clients{$cid}->{inmessagedelay},
                    );
                    push @{$clients{$cid}->{inmessages}}, \%inmsg;
                    $clients{$cid}->{buffer} = '';
                } else {
                    $clients{$cid}->{buffer} .= $buf;
                }
            }

            if($interclackslock && !$clients{$cid}->{interclacksclient}) {
                # We are locked into interclacks sync lock, but this is not the connection to master,
                # so we don't handle the input buffer for this client at the moment.
                next;
            }


            # ******************************************************************************
            # ******************************************************************************
            # ******************************************************************************
            # ******************************************************************************
            # ******************************************************************************
            # ******************************************************************************
            # ******************************************************************************
            while(scalar @{$clients{$cid}->{inmessages}}) {
                last if($clients{$cid}->{inmessages}->[0]->{releasetime} > $now);
                my $inmsgtmp = shift @{$clients{$cid}->{inmessages}};
                my $inmsg = $inmsgtmp->{message};

                # Handle CLACKS identification header
                if($inmsg =~ /^CLACKS\ (.+)/) {
                    $clients{$cid}->{clientinfo} = $1;
                    $clients{$cid}->{clientinfo} =~ s/\;/\_/g;
                    print "Client at ", $cid, " identified as ", $clients{$cid}->{clientinfo}, "\n";
                    next;
                }

                my $nodebug = 0;
                my $sendinterclacks = 1;
                my $discardafterlogging = 0;
                # Handle OVERHEAD messages before logging (for handling 'N' flag correctly)
                if($inmsg =~ /^OVERHEAD\ (.+?)\ (.+)/) {
                    my ($flags, $value) = ($1, $2);
                    $sendinterclacks = 0;
                    my @flagparts = split//, $flags;
                    my %parsedflags;
                    my %newflags;
                    foreach my $key (sort keys %overheadflags) {
                        if(contains($key, \@flagparts)) {
                            $parsedflags{$overheadflags{$key}} = 1;
                            $newflags{$overheadflags{$key}} = 1;
                        } else {
                            $parsedflags{$overheadflags{$key}} = 0;
                            $newflags{$overheadflags{$key}} = 0;
                        }
                    }

                    if($parsedflags{auth_token}) {
                        if($value eq $self->{authtoken}) {
                            $clients{$cid}->{authok} = 1;
                            #$clients{$cid}->{outbuffer} .= "OVERHEAD O Welcome!\r\n";
                            push @{$clients{$cid}->{outmessages}}, {releasetime => $now + $clients{$cid}->{outmessagedelay}, message => 'OVERHEAD O Welcome!'};
                        } else {
                            $clients{$cid}->{authok} = 0;
                            #$clients{$cid}->{outbuffer} .= "OVERHEAD F Login failed!\r\n";
                            push @{$clients{$cid}->{outmessages}}, {releasetime => $now + $clients{$cid}->{outmessagedelay}, message => 'OVERHEAD F Login failed!'};
                            push @{$clients{$cid}->{outmessages}}, {releasetime => $now + $clients{$cid}->{outmessagedelay}, message => 'EXIT'};
                            push @toremove, $cid; # Disconnect the client
                            last;
                        }
                    }

                    # Ignore other command when not authenticated
                    if(!$clients{$cid}->{authok}) {
                        next;
                    }

                    if($parsedflags{timestamp}) {
                        $now = $self->getTime(); # Make sure we are at the "latest" $now. This is one of the very few critical sections
                        $clients{$cid}->{client_timeoffset} = $now - $value;
                        print "**** CLIENT TIME OFFSET: ", $clients{$cid}->{client_timeoffset}, "\n";
                        next;
                    }

                    if($parsedflags{lock_for_sync} && $clients{$cid}->{interclacksclient}) {
                        if($value) {
                            print "Interclacks sync lock ON.\n";
                            $interclackslock = 1;
                        } else {
                            print "Interclacks sync lock OFF.\n";
                            $interclackslock = 0;

                            # Send server our keys AFTER we got everything FROM the server (e.g. after unlock)
                            $clients{$cid}->{outbuffer} .= "OVERHEAD T " . $self->getTime() . "\r\n"; # Send local time to server for offset calculation
                            foreach my $ckey (sort keys %{$self->{clackscache}}) {
                                $clients{$cid}->{outbuffer} .= "KEYSYNC " . $self->{clackscachetime}->{$ckey} . " " . $self->{clackscacheaccesstime}->{$ckey} . " U $ckey=" . $self->{clackscache}->{$ckey} . "\r\n";
                            }
                            foreach my $ckey (sort keys %{$self->{clackscachetime}}) {
                                next if(defined($self->{clackscache}->{$ckey}));
                                $clients{$cid}->{outbuffer} .= "KEYSYNC " . $self->{clackscachetime}->{$ckey} . " 0 D $ckey=REMOVED\r\n";
                            }
                        }
                        $parsedflags{forward_message} = 0; # Don't forward
                        $newflags{return_to_sender} = 0; # Don't return to sender
                    }

                    if($parsedflags{close_all_connections} && $value) {
                        foreach my $closecid (keys %clients) {
                            if($clients{$closecid}->{interclacks} && $parsedflags{forward_message}) {
                                $self->evalsyswrite($clients{$closecid}->{socket}, "\r\nOVERHEAD GC 1\r\n");
                            }
                            $self->evalsyswrite($clients{$closecid}->{socket}, "\r\nQUIT\r\n");
                            push @toremove, $closecid;
                        }
                        $parsedflags{forward_message} = 0; # Already forwarded where needed
                    }

                    if($parsedflags{shutdown_service}) {
                        $value = 0 + $value;
                        if($value > 0) {
                            $shutdowntime = $value + $now;
                            print STDERR "Shutting down in $value seconds\n";
                        }
                    }
                    if($parsedflags{discard_message}) {
                        $discardafterlogging = 1;
                    }
                    if($parsedflags{no_logging}) {
                        $nodebug = 1;
                    }

                    if($parsedflags{error_message}) {
                        print STDERR 'ERROR from ', $cid, ': ', $value, "\n";
                    }

                    if($parsedflags{set_interclacks_mode}) {
                        $newflags{forward_message} = 0;
                        $newflags{return_to_sender} = 0;

                        if($value) {
                            $clients{$cid}->{interclacks} = 1;
                            $clients{$cid}->{lastping} = $now;


                            $clients{$cid}->{outbuffer} .= "CLACKS PageCamel $VERSION in interclacks master mode\r\n" .  # Tell client we are in interclacks master mode
                                                           "OVERHEAD M Authentication required\r\n" .                 # Informal message
                                                           "OVERHEAD A " . $self->{authtoken} . "\r\n" .              # ...and send Auth token...
                                                           "OVERHEAD L 1\r\n" .                                       # ...and lock client for sync
                                                           "OVERHEAD T " . time . "\r\n";                             # ... and send local timestamp

                            # Make sure our new interclacks client has an *exact* copy of our buffer
                            #$clients{$cid}->{outbuffer} .= "CLEARCACHE\r\n";
                            foreach my $ckey (sort keys %{$self->{clackscache}}) {
                                $clients{$cid}->{outbuffer} .= "KEYSYNC " . $self->{clackscachetime}->{$ckey} . " " . $self->{clackscacheaccesstime}->{$ckey} . " U $ckey=" . $self->{clackscache}->{$ckey} . "\r\n";
                            }
                            foreach my $ckey (sort keys %{$self->{clackscachetime}}) {
                                next if(defined($self->{clackscache}->{$ckey}));
                                $clients{$cid}->{outbuffer} .= "KEYSYNC " . $self->{clackscachetime}->{$ckey} . " 0 D $ckey=REMOVED\r\n";
                            }
                            $clients{$cid}->{outbuffer} .= "OVERHEAD L 0\r\n"; # unlock client after sync
                            $clients{$cid}->{outbuffer} .= "PING\r\n";
                            $clients{$cid}->{lastinterclacksping} = $now;
                        } else {
                            $clients{$cid}->{interclacks} = 0;
                            $clients{$cid}->{lastping} = $now;
                        }
                    }

                    my $newflagstring = '';
                    $newflags{return_to_sender} = 0;

                    foreach my $key (sort keys %overheadflags) {
                        next if($key eq 'Z');
                        if($newflags{$overheadflags{$key}}) {
                            $newflagstring .= $key;
                        }
                    }
                    if($newflagstring eq '') {
                        $newflagstring = 'Z';
                    }

                    if($parsedflags{forward_message}) {
                        foreach my $overheadcid (keys %clients) {
                            next if($cid eq $overheadcid && !$parsedflags{return_to_sender});

                            $clients{$overheadcid}->{outbuffer} .= "OVERHEAD $newflagstring $value\r\n";
                        }
                    }
                }

                # Ignore other command when not authenticated
                if(!$clients{$cid}->{authok}) {
                    next;
                }

                if(!$nodebug) {
                    # Add ALL incoming messages as debug-type messages to the outbox
                    my %tmp = (
                        sender => $cid,
                        type => 'DEBUG',
                        data => $inmsg,
                    );

                    push @outbox, \%tmp;
                }

                if($discardafterlogging) {
                    next;
                }


                if($inmsg =~ /^OVERHEAD\ /) { ## no critic (ControlStructures::ProhibitCascadingIfElse)
                    # Already handled
                } elsif($inmsg =~ /^LISTEN\ (.*)/) {
                    $clients{$cid}->{listening}->{$1} = 1;
                    $sendinterclacks = 0;
                } elsif($inmsg =~ /^UNLISTEN\ (.*)/) {
                    delete $clients{$cid}->{listening}->{$1};
                    $sendinterclacks = 0;
                } elsif($inmsg =~ /^MONITOR/) {
                    $clients{$cid}->{mirror} = 1;
                    $sendinterclacks = 0;
                } elsif($inmsg =~ /^UNMONITOR/) {
                    $clients{$cid}->{mirror} = 0;
                    $sendinterclacks = 0;
                } elsif($inmsg =~ /^QUIT/) {
                    print STDERR "Client disconnected cleanly!\n";
                    push @toremove, $cid;
                    $sendinterclacks = 0;
                } elsif($inmsg =~ /^TIMEOUT/ && $clients{$cid}->{interclacks}) {
                    print STDERR "Ooops, didn't send timely PINGS through interclacks link!\n";
                    push @toremove, $cid;
                    $sendinterclacks = 0;
                } elsif($inmsg =~ /^PING/) {
                    $clients{$cid}->{lastping} = $now;
                    $sendinterclacks = 0;
                } elsif($inmsg =~ /^NOPING/) {
                    # Disable PING check until next PING recieved
                    $clients{$cid}->{lastping} = 0;
                    $sendinterclacks = 0;
                } elsif($inmsg =~ /^NOTIFY\ (.*)/) {
                    my %tmp = (
                        sender => $cid,
                        type => 'NOTIFY',
                        name => $1,
                    );
                    push @outbox, \%tmp;
                } elsif($inmsg =~ /^SET\ (.+?)\=(.*)/) {
                    my %tmp = (
                        sender => $cid,
                        type => 'SET',
                        name => $1,
                        value => $2,
                    );
                    push @outbox, \%tmp;
                } elsif($inmsg =~ /^KEYSYNC\ (.+?)\ (.+?)\ (.+?)\ (.+?)\=(.*)/) {
                    #print "***** ", $inmsg, "\n";
                    my ($ctimestamp, $atimestamp, $cmode, $ckey, $cval) = ($1, $2, $3, $4, $5);
                    $clients{$cid}->{lastping} = $now; # KEYSYNC acts as a PING as well

                    $ctimestamp += $clients{$cid}->{client_timeoffset}; # Take client time offset into account
                    if($atimestamp) {
                        $atimestamp += $clients{$cid}->{client_timeoffset}; # Take client time offset into account
                    }

                    if(!defined($self->{clackscachetime}->{$ckey})) {
                        $self->{clackscachetime}->{$ckey} = 0;
                    }
                    if(!defined($self->{clackscachetime}->{$ckey}) || $ctimestamp > $self->{clackscachetime}->{$ckey}) {
                        # If *we* have the older entry (or none at all), *only* then work on the keysync command
                        if($cmode eq "U") { # "Update"
                            $self->{clackscache}->{$ckey} = $cval;
                            $self->{clackscachetime}->{$ckey} = $ctimestamp;
                            $self->{clackscacheaccesstime}->{$ckey} = $atimestamp;
                        } else { # REMOVE request from server
                            $self->{clackscachetime}->{$ckey} = $ctimestamp;
                            if(defined($self->{clackscache}->{$ckey})) {
                                delete $self->{clackscache}->{$ckey};
                            }
                            if(defined($self->{clackscacheaccesstime}->{$ckey})) {
                                delete $self->{clackscacheaccesstime}->{$ckey};
                            }
                        }
                    }

                    $savecache = 1;
                    $sendinterclacks = 1;
                } elsif($inmsg =~ /^STORE\ (.+?)\=(.*)/) {
                    $self->{clackscache}->{$1} = $2;
                    $self->{clackscachetime}->{$1} = $now;
                    $self->{clackscacheaccesstime}->{$1} = $now;
                    $savecache = 1;
                } elsif($inmsg =~ /^SETANDSTORE\ (.+?)\=(.*)/) {
                    my %tmp = (
                        sender => $cid,
                        type => 'SETANDSTORE',
                        name => $1,
                        value => $2,
                    );
                    push @outbox, \%tmp;
                    $self->{clackscache}->{$tmp{name}} = $tmp{value};
                    $self->{clackscachetime}->{$tmp{name}} = $now;
                    $self->{clackscacheaccesstime}->{$tmp{name}} = $now;
                    $savecache = 1;
                } elsif($inmsg =~ /^RETRIEVE\ (.+)/) {
                    #$clients{$cid}->{outbuffer} .= "SET ". $line->{name} . "=" . $line->{value} . "\r\n";
                    my $ckey = $1;
                    if(defined($self->{clackscache}->{$ckey})) {
                        $clients{$cid}->{outbuffer} .= "RETRIEVED $ckey=" . $self->{clackscache}->{$ckey} . "\r\n";
                        $self->{clackscacheaccesstime}->{$ckey} = $now;
                        $savecache = 1;
                    } else {
                        $clients{$cid}->{outbuffer} .= "NOTRETRIEVED $ckey\r\n";
                    }
                    $sendinterclacks = 0;
                } elsif($inmsg =~ /^REMOVE\ (.+)/) {
                    my $ckey = $1;
                    if(defined($self->{clackscache}->{$ckey})) {
                        delete $self->{clackscache}->{$ckey};
                        $self->{clackscachetime}->{$ckey} = $now;
                    }
                    if(defined($self->{clackscacheaccesstime}->{$ckey})) {
                        delete $self->{clackscacheaccesstime}->{$ckey};
                    }
                    $savecache = 1;
                } elsif($inmsg =~ /^INCREMENT\ (.+)/) {
                    my $ckey = $1;
                    my $cval = 1;
                    if($ckey =~ /(.+)\=(.+)/) {
                        ($ckey, $cval) = ($1, $2);
                        $cval = 0 + $cval;
                    }
                    if(defined($self->{clackscache}->{$ckey})) {
                        $self->{clackscache}->{$ckey} += $cval;
                    } else {
                        $self->{clackscache}->{$ckey} = $cval;
                    }
                    $self->{clackscachetime}->{$ckey} = $now;
                    $self->{clackscacheaccesstime}->{$ckey} = $now;
                    $savecache = 1;
                } elsif($inmsg =~ /^DECREMENT\ (.+)/) {
                    my $ckey = $1;
                    my $cval = 1;
                    if($ckey =~ /(.+)\=(.+)/) {
                        ($ckey, $cval) = ($1, $2);
                        $cval = 0 + $cval;
                    }
                    if(defined($self->{clackscache}->{$ckey})) {
                        $self->{clackscache}->{$ckey} -= $cval;
                    } else {
                        $self->{clackscache}->{$ckey} = 0 - $cval;
                    }
                    $self->{clackscachetime}->{$ckey} = $now;
                    $self->{clackscacheaccesstime}->{$ckey} = $now;
                    $savecache = 1;
                } elsif($inmsg =~ /^KEYLIST/) {
                    $clients{$cid}->{outbuffer} .= "KEYLISTSTART\r\n";
                    foreach my $ckey (sort keys %{$self->{clackscache}}) {
                        $clients{$cid}->{outbuffer} .= "KEY $ckey\r\n";
                    }
                    $clients{$cid}->{outbuffer} .= "KEYLISTEND\r\n";
                    $sendinterclacks = 0;
                } elsif($inmsg =~ /^CLEARCACHE/) {
                    %{$self->{clackscache}} = ();
                    %{$self->{clackscachetime}} = ();
                    %{$self->{clackscacheaccesstime}} = ();
                    $savecache = 1;

                # local managment commands
                } elsif($inmsg =~ /^CLIENTLIST/) {
                    $clients{$cid}->{outbuffer} .= "CLIENTLISTSTART\r\n";
                    foreach my $lmccid (sort keys %clients) {
                        $clients{$cid}->{outbuffer} .= "CLIENT CID=$lmccid;" .
                                                            "HOST=" . $clients{$lmccid}->{host} . ";" .
                                                            "PORT=" . $clients{$lmccid}->{port} . ";" .
                                                            "CLIENTINFO=" . $clients{$lmccid}->{clientinfo} . ";" .
                                                            "OUTBUFFER_LENGTH=" . length($clients{$lmccid}->{outbuffer}) . ";" .
                                                            "INBUFFER_LENGTH=" . length($clients{$lmccid}->{buffer}) . ";" .
                                                            "INTERCLACKS=" . $clients{$lmccid}->{interclacks} . ";" .
                                                            "MONITOR=" . $clients{$lmccid}->{mirror} . ";" .
                                                            "LASTPING=" . $clients{$lmccid}->{lastping} . ";" .
                                                            "LASTINTERCLACKSPING=" . $clients{$lmccid}->{lastinterclacksping} . ";" .
                                                            "\r\n";
                    }
                    $clients{$cid}->{outbuffer} .= "CLIENTLISTEND\r\n";
                    $sendinterclacks = 0;
                } elsif($inmsg =~ /^CLIENTDISCONNECT\ (.+)/) {
                    my $lmccid = $1;
                    if(defined($clients{$lmccid})) {
                        # Try to notify the client (may or may not work);
                        $self->evalsyswrite($clients{$lmccid}->{socket}, "\r\nQUIT\r\n");
                        push @toremove, $lmccid;
                    }
                    $sendinterclacks = 0;
                } elsif($inmsg =~ /^FLUSH\ (.+)/) {
                    my $retid = $1;
                    $clients{$cid}->{outbuffer} .= "FLUSHED $retid\r\n";
                    $sendinterclacks = 0;
                } else {
                    print STDERR "ERROR Unknown_command ", $inmsg, "\r\n";
                    $sendinterclacks = 0;
                    $clients{$cid}->{outbuffer} .= "OVERHEAD E unknown_command " . $inmsg . "\r\n";
                }

                # forward interclacks messages
                if($sendinterclacks) {
                    foreach my $interclackscid (keys %clients) {
                        if($cid eq $interclackscid || !$clients{$interclackscid}->{interclacks}) {
                            next;
                        }
                        $clients{$interclackscid}->{outbuffer} .= $inmsg . "\r\n";
                    }
                }

            }

        }

        # clean up very old "deleted" entries
        my $stillvalidtime = $now - $self->{config}->{deletedcachetime};
        foreach my $key (keys %{$self->{clackscachetime}}) {
            next if($self->{clackscachetime}->{$key} > $stillvalidtime);
            if(defined($self->{clackscache}->{$key})) { # Still has data? Fix clackscachetime entry
                $self->{clackscachetime}->{$key} = $now;
            }
            delete $self->{clackscachetime}->{$key};
            $savecache = 1;
        }

        # Clean up (forget) stale cached entries
        $stillvalidtime = $now - $self->{config}->{stalecachetime};
        foreach my $key (keys %{$self->{clackscacheaccesstime}}) {
            next if($self->{clackscacheaccesstime}->{$key} > $stillvalidtime);
            delete $self->{clackscacheaccesstime}->{$key};
            if(defined($self->{clackscache})) {
                delete $self->{clackscache}->{$key};
            }
            if(defined($self->{clackscachetime})) {
                delete $self->{clackscachetime}->{$key};
            }

            my %tmp = (
                sender => 'SERVERCACHE',
                type => 'DEBUG',
                data => 'FORGET=' . $key,
            );

            push @outbox, \%tmp;
        }


        # Outbox contains the messages that have to be forwarded to the clients when listening (or when the connection is in interclacks mode)
        # We iterate over the outbox and put those messages into the output buffers of the corresponding client connection
        while((my $line = shift @outbox)) {
            $workCount++;
            foreach my $cid (keys %clients) {
                if($line->{type} eq 'DEBUG' && $clients{$cid}->{mirror}) {
                    $clients{$cid}->{outbuffer} .= "DEBUG " . $line->{sender} . "=". $line->{data} . "\r\n";
                }

                if($cid eq $line->{sender}) {
                    next;
                }

                if($line->{type} ne 'DEBUG' && defined($clients{$cid}->{listening}->{$line->{name}})) {
                    # Just buffer in the clients outbuffers
                    if($line->{type} eq 'NOTIFY') {
                        $clients{$cid}->{outbuffer} .= "NOTIFY ". $line->{name} . "\r\n";
                    } elsif($line->{type} eq 'SET') {
                        $clients{$cid}->{outbuffer} .= "SET ". $line->{name} . "=" . $line->{value} . "\r\n";
                    } elsif($line->{type} eq 'SETANDSTORE') {
                        # We forward SETANDSTORE as such only over interclacks connections. Basic clients don't have a cache,
                        # so we only send a SET command
                        if($clients{$cid}->{interclacks}) {
                            $clients{$cid}->{outbuffer} .= "SETANDSTORE ". $line->{name} . "=" . $line->{value} . "\r\n";
                        } else {
                            $clients{$cid}->{outbuffer} .= "SET ". $line->{name} . "=" . $line->{value} . "\r\n";
                        }
                    }
                }
            }
        }


        # Push all messages that can be released at this time into the corresponding char based output for each client
        foreach my $cid (keys %clients) {
            while(scalar @{$clients{$cid}->{outmessages}}) {
                last if($clients{$cid}->{outmessages}->[0]->{releasetime} > $now);

                my $outmsg = shift @{$clients{$cid}->{outmessages}};
                if($outmsg->{message} eq 'EXIT') {
                    push @toremove, $cid; # Disconnect the client
                } else {
                    $clients{$cid}->{outbuffer} .= $outmsg->{message} . "\r\n";
                }
            }
        }

            # ******************************************************************************
            # ******************************************************************************
            # ******************************************************************************
            # ******************************************************************************
            # ******************************************************************************
            # ******************************************************************************
            # ******************************************************************************

        # Send as much as possible
        foreach my $cid (keys %clients) {
            if(length($clients{$cid}->{outbuffer})) {
                $clients{$cid}->{lastmessage} = $now;
            } elsif(($clients{$cid}->{lastmessage} + 60) < $now) {
                $clients{$cid}->{lastmessage} = $now;
                $clients{$cid}->{outbuffer} .= "NOP\r\n"; # send "No OPerations" command, just to
                                                          # check if socket is still open
            }

            next if(!length($clients{$cid}->{outbuffer}));

            # Output bandwidth-limited stuff, in as big chunks as possible
            my $written;
            $workCount++;
            eval { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
                $written = syswrite($clients{$cid}->{socket}, $clients{$cid}->{outbuffer});
            };
            if($EVAL_ERROR) {
                print STDERR "Write error: $EVAL_ERROR\n";
                push @toremove, $cid;
                next;
            }
            if(!$clients{$cid}->{socket}->opened || $clients{$cid}->{socket}->error || ($ERRNO ne '' && !$ERRNO{EWOULDBLOCK})) {
                print STDERR "webPrint write failure: $ERRNO\n";
                push @toremove, $cid;
                next;
            }

            if(defined($written) && $written) {
                if(length($clients{$cid}->{outbuffer}) == $written) {
                    $clients{$cid}->{outbuffer} = '';
                } else {
                    $clients{$cid}->{outbuffer} = substr($clients{$cid}->{outbuffer}, $written);
                }
            }
        }

        if($workCount) {
            $self->{usleep} = 0;
        } elsif($self->{usleep} < $self->{config}->{throttle}->{maxsleep}) {
            $self->{usleep} += $self->{config}->{throttle}->{step};
        }
        if($self->{usleep}) {
            sleep($self->{usleep} / 1000);
        }
    }

    print "Shutting down...\n";

    # Make sure we save the latest version of the persistance file
    $self->savePersistanceFile($savecache);

    sleep(0.5);
    foreach my $cid (keys %clients) {
        print "Removing client $cid\n";
        # Try to notify the client (may or may not work);
        $self->evalsyswrite($clients{$cid}->{socket}, "\r\nQUIT\r\n");

        delete $clients{$cid};
    }
    print "All clients removed\n";


    return;
}
sub savePersistanceFile($self, $savecache) {
    if(!$self->{persistance}) {
        return;
    }

    print "Saving persistance file\n";
    my $line = Dump($self->{clackscache});
    $line = encode_base64($line, '');
    my $timestampline = Dump($self->{clackscachetime});
    $timestampline = encode_base64($timestampline, '');
    my $accesstimeline = Dump($self->{clackscacheaccesstime});
    $accesstimeline = encode_base64($accesstimeline, '');

    my $tempfname = $self->{config}->{persistancefile} . '_';
    my $backfname = $self->{config}->{persistancefile} . '_bck';
    if($savecache == 1) {
        # Normal savecache operation only
        copy($self->{config}->{persistancefile}, $backfname);
    }

    if(open(my $ofh, '>', $tempfname)) {
        print $ofh $line, "\n";
        print $ofh $timestampline, "\n";
        print $ofh $accesstimeline, "\n";
        print $ofh "ENDBYTES\n";
        close $ofh;
    }
    move($tempfname, $self->{config}->{persistancefile});

    if($savecache == 2) {
        # Need to make sure we have a valid backup file, since we had a general problem while loading
        copy($self->{config}->{persistancefile}, $backfname);
    }

    return;
}

sub deref($self, $val) {
    return if(!defined($val));

    while(ref($val) eq "SCALAR" || ref($val) eq "REF") {
        $val = ${$val};
        last if(!defined($val));
    }

    return $val;
}

sub evalsyswrite($self, $socket, $buffer) {
    return 0 unless(length($buffer));

    my $written = 0;
    my $ok = 0;
    eval { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
        $written = syswrite($socket, $buffer);
        $ok = 1;
    };
    if($EVAL_ERROR || !$ok) {
        print STDERR "Write error: $EVAL_ERROR\n";
        return -1;
    }

    return $written;
}

sub getTime($self) {
    my $now = time + $self->{timeoffset};

    return $now;
}

sub slurpBinFile($fname) {
    # Read in file in binary mode, slurping it into a single scalar.
    # We have to make sure we use binmode *and* turn on the line termination variable completly
    # to work around the multiple idiosynchrasies of Perl on Windows
    open(my $fh, "<", $fname) or croak($ERRNO);
    local $INPUT_RECORD_SEPARATOR = undef;
    binmode($fh);
    my $data = <$fh>;
    close($fh);

    return $data;
}



1;
__END__