#!/usr/bin/perl
# nonforker - server who multiplexes without forking
use strict;
use warnings;

use POSIX;
use IO::Socket;
use IO::Select;
use Socket;
use Fcntl;
use Tie::RefHash;

# begin with empty buffers
my %inbuffer  = ();
my %outbuffer = ();
my %ready     = ();
my %clientcommands = ();

tie %ready, 'Tie::RefHash';


# Listen to port.
my $port = 3009;
my $server = IO::Socket::INET->new(
	LocalPort => $port,
    Listen    => 10
) or die "Can't make server socket: $@\n";
nonblock($server);

my $select = IO::Select->new($server);

# Commands hash.
my %commands = (
	REG => \&cmd_reg,
	UNREG => \&cmd_unreg,
	ISREG => \&cmd_isreg,
	LSREG => \&cmd_lsreg,
);

#############
# Main loop #
#############

# check reads/accepts, check writes, check ready to process
while (1) {
    my $client;
    my $rv;
    my $data;

    # check for new information on the connections we have

    # anything to read or accept?
    foreach $client ($select->can_read(1)) {

        if ($client == $server) {
            # accept a new connection

            $client = $server->accept();
            $select->add($client);
            nonblock($client);
        } else {
            # read data
            $data = '';
            $rv   = $client->recv($data, POSIX::BUFSIZ, 0);

            unless (defined($rv) && length $data) {
                # This would be the end of file, so close the client
                delete $inbuffer{$client};
                delete $outbuffer{$client};
                delete $ready{$client};

				# Clean up commands.
				for my $cmd (@{$clientcommands{$client}}) {
					delete $commands{$cmd};
				}
				delete $clientcommands{$client};

                $select->remove($client);
                close $client;
                next;
            }

            $inbuffer{$client} .= $data;

            # test whether the data in the buffer or the data we
            # just read means there is a complete request waiting
            # to be fulfilled.  If there is, set $ready{$client}
            # to the requests waiting to be fulfilled.
            while ($inbuffer{$client} =~ s/(.*\n)//) {
                push( @{$ready{$client}}, $1 );
            }
        }
    }

    # Any complete requests to process?
    foreach $client (keys %ready) {
        handle($client);
    }

    # Buffers to flush?
    foreach $client ($select->can_write(1)) {
        # Skip this client if we have nothing to say
        next unless exists $outbuffer{$client};

        $rv = $client->send($outbuffer{$client}, 0);
        unless (defined $rv) {
            # Whine, but move on.
            warn "I was told I could write, but I can't.\n";
            next;
        }
        if ($rv == length $outbuffer{$client} || $! == POSIX::EWOULDBLOCK) {
            substr($outbuffer{$client}, 0, $rv) = '';
            delete $outbuffer{$client} unless length $outbuffer{$client};
        } else {
            # Couldn't write all the data, and it wasn't because
            # it would have blocked.  Shutdown and move on.
            delete $inbuffer{$client};
            delete $outbuffer{$client};
            delete $ready{$client};

            $select->remove($client);
            close($client);
            next;
        }
    }

    # Out of band data?
    foreach $client ($select->has_exception(0)) {  # arg is timeout
        # Deal with out-of-band data here, if you want to.
    }
}

###################
# handle($client) #
###################

# deals with all pending requests for $client
sub handle {
    # requests are in $ready{$client}
    # send output to $outbuffer{$client}
    my $client = shift;

    for (@{$ready{$client}}) {
        # $_ is the text of the request, including the newline.
        # put text of reply into $outbuffer{$client}

		# Remove line ending.
		s/\r\n// || s/\n//;
    	print "Received: $_\n";

		(my $cmd) = /^([^ \t]*)/gc;
		if ( ! $cmd ) {
			# Regex failed for some reason.
			reply($client, 'ERR Leading spaces?');
		} elsif (exists($commands{$cmd})) {
			# Command exists, so extract any arguments.
			(my $args) = /\G ([^\t]*)/g;
			if (ref($commands{$cmd}) eq "CODE" ) {
				# Command is a builtin; call the subroutine.
				&{$commands{$cmd}}($client, $args)
			} else {
				# Command is for a module; send the line on.
    			$outbuffer{$commands{$cmd}} = "$_\r\n";
    			print ' - ', "sent to ``$cmd''.\n"
			}
		} else {
			# Command does not exist, so reply with error.
			reply($client, "ERR $cmd - No such command.");
		}
    }
    delete $ready{$client};
}

#####################
# nonblock($socket) #
#####################

# puts socket into nonblocking mode
sub nonblock {
    my $socket = shift;
    my $flags;
    
    $flags = fcntl($socket, F_GETFL, 0)
            or die "Can't get flags for socket: $!\n";
    fcntl($socket, F_SETFL, $flags | O_NONBLOCK)
            or die "Can't make socket nonblocking: $!\n";
}

#########################
# reply($client,$reply) #
#########################

# Send a reply to a client in a standard way.
sub reply {
	my ($client, $reply) = @_;
	$outbuffer{$client} = $reply . $/;
	print 'Replying: ', $reply, "\n";
}

##########################
# cmd_reg($client,$args) #
##########################

# Register a command.
# Two arguments: $client - the id of the client making the request
# 				 $args	 - the command to register
sub cmd_reg {
	my ($client, $args) = @_;
	# Check if the command already exists.
    if (exists $commands{$args}) {
		# Respond with an error.
		reply($client, "ERR REG $args");
    } else {
		# Register the command.
    	$commands{$args} = $client;
		push(@{$clientcommands{$client}}, $args);
		reply($client, "OK REG $args");
    }
}

############################
# cmd_unreg($client,$args) #
############################

# Unregister a command.
# Two arguments: $client - the id of the client making the request
# 				 $args	 - the command to unregister
sub cmd_unreg {
	my ($client, $args) = @_;
	# Check the command exists.
    if (exists $commands{$args}) {
    	if ($client == $commands{$args}) {
    		delete $commands{$args};
			@{$clientcommands{$client}} = grep {!/$args/} @{$clientcommands{$client}};
			reply($client, "OK UNREG $args");
    	} else {
    		reply($client, "ERR UNREG $args - Wrong module.");
    	}
    } else {
		reply($client, "ERR UNREG $args - Not registered.");
    }
}

############################
# cmd_isreg($client,$args) #
############################

# Check if a command is registered.
sub cmd_isreg {
	my ($client, $args) = @_;
	# Check if the command exists.
	if (exists $commands{$args}) {
		reply($client, "OK ISREG $args");
	} else {
		reply($client, "NOREG $args");
	}
}

############################
# cmd_lsreg($client,$args) #
############################

# List registered commands.
sub cmd_lsreg {
	my ($client, $args) = @_;
	reply($client, "LSREG " . join(' ', keys %commands) );
}

# Called upon receipt of SIGHUP.
# Execs new version of the core, passing all file descriptors along.
# File descriptors equate to filenames in /proc/self/fd/
#sub restart {
#	glob("/proc/self/fd/*");	
#	exec($0, "");
#}