#!/usr/bin/perl -w

=head1 serve_binary.pl

=item Written: 20021230

=back

=item Creator: Andrew Robertson

=back

=item Revised: N/A

=back

=item Version: 1.0

=back

=item License: GPL 2

=back

    Copyright (C) 2002 Andrew Robertson <critter_75075@yahoo.com>

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

Description:

  serve_binary.pl is a simple multi-process binary server.  This is meant to
  be a terminal type application with basically unlimited clients.  To use
  this application, telnet must be set to character mode.  Simple configure
  the commands you want into %messages, along with their handlers.

  You should not have any problems changing this server to support non-terminal
  applications, such as binary application servers.

  Remember to change the LocalAddr and LocalPort options in the ..INET->new
  command!

References:

  Some of serve_http.pl is based on a demo server in the Advanced Perl
  Programming book by Siram Srinivasan, First Printing Copyright 1997.

  Also used where www.deja.com, perldoc perlfunc, and Perl Cookbook by Randal Schwartz.

Global Variables:

	my @live_children = ([pid, socket reference],...) # List of all
		live children and their respective sockets.
	my $message_level = integer; # Logging level
	my $child_timeout = seconds; # Time to let children live
	my %messages = (text => \&handler,...); # List of all command handlers
		Where:
			text is a string with the characters of the command
			\&handler is a subroutine for handling the command.  To
				all handlers a reference to the socket is sent.
				Could be $handler or sub {...;}.  If you want to
				support the command then <enter> key format, include
				\r\n at the end of the text in line mode, and \r\x00
				in character mode, respectively.

=cut

use strict;
use IO::Socket::INET;
use POSIX ":sys_wait_h";

my @live_children;		# Store children PID's with their socket references
my $message_level = 2;
my $child_timeout = 360; # six minutes

################################################################################

=head2 sub print_char

Description:

  subroutine print_char prints the character entered next into the socket.
  Used to demonstrate command arguments. 

=cut

sub print_char {

	my $socket = shift;
	my $buf;
	while(1) {
		my $bytes_read = sysread($socket, $buf, 1);
		if (defined($bytes_read) and ($bytes_read == 0)) {
			# Socket closed
			logmessage(11, 'print_char', 'socket closed');
			exit(0);
		} else {
			print $socket $buf;
			last;
		}
	}

}

################################################################################

=head2 sub print_string

Description:

  subroutine print_string prints the characters entered next into the socket
  until a carrage return is encountered.  After the carriage return, one more
  character is taken off of the socket, then the subroutine returns.

=cut

sub print_string {

	my $socket = shift;
	my $short_buf;
	my $main_buf = '';
	while(1) {
		my $bytes_read = sysread($socket, $short_buf, 1);
		if (defined($bytes_read) and ($bytes_read == 0)) {
			# Socket closed
			logmessage(11, 'print_char', 'socket closed');
			exit(0);
		} elsif ($short_buf ne "\r") {
			$main_buf .= $short_buf;
		} else {
			print $socket $main_buf;
			# flush off \n or \x00
			my $bytes_read = sysread($socket, $short_buf, 1);
			last;
		}
	}
	return(1);

}

################################################################################

=head2 sub print

Description:

  subroutine print prints a message to the client.  In this case, hello.

=cut

sub print {

	my $socket = shift;
	print $socket 'hello';

}

################################################################################

=head2 sub quit

Description:

  subroutine quit prints a good bye message to the client then exits.  It is up
  to the main program to close the socket.

=cut

sub quit {

	my $socket = shift;
	print $socket "Good bye!\r\n";
	logmessage (0, 'sub quit', 'child exiting');
	exit(0);
}

################################################################################

=head2 sub noop

Description:

  Does nothing

=cut

sub noop {
}

################################################################################

=head2 sub help

Description:

  Prints off the available commands

=cut

sub help {
	my $socket = shift;
	print $socket "\r\nq => quit\r\n";
	print $socket "noop => does nothing\r\n";
	print $socket "pr => print hello\r\n";
	print $socket "h => print this message\r\n";
	print $socket "P<X> => print <X> (single char) on screen\r\n";
	print $socket "echo <string> => print <string> multichar on screen\r\n";
}

################################################################################

=head2 sub unknown_command

Description:

  Prints off an error message for any unknown commands

=cut

sub unknown_command {
	my $socket = shift;
	if (defined($socket)) {
		print $socket "Unknown command\r\n";
	}
}

################################################################################

my %messages = ('q' => \&quit,
		'noop' => \&noop,
		'pr' => \&print,
		'h' => \&help,
		'P' => \&print_char,
		'echo ' => \&print_string,
		"\r\n" => \&help, # works in line mode when you hit enter
		"\r\x00" => \&help, # works in character mode when you hit enter
		);

my $message;
my $max_length = 0;
my $main_buffer = '';
my $main_buffer_length = 0;
foreach $message (keys(%messages)) {
	if ($max_length < length($message)) {$max_length = length($message);}
}

# Clean up after spawned children.

################################################################################

=head2 sub logmessage

Description:

  logmessage handles messages, including errors.  You may configure this to write to files
  or just to print the messages.

Levels:
	0:	Major program events (starting and stopping)
	1:	Initialization
	2:	Main HTTP transactions
	3:	Subroutine start and stop
	4:	Subroutine/block markers
	5:	Variable contents
	10:	Program errors
	11:	HTTP errors

=cut

sub logmessage {
	my ($level, $block, $message) = @_;
	if ($level <= $message_level) {
		print $block, ' ', $message, "\n";
	} elsif ($level >= 10) {
		print "Error: $block $message\n";
	}
}

################################################################################

=head2 sub clean

Description:

  Using the @live_children global variable, subroutine clean closes the sockets for dead children.

=cut

sub clean {

	logmessage(3, 'sub clean', 'started');

	my @new_children_list;
	my $temp_array;
	foreach $temp_array(@live_children) {
		# use posix type non blocking wait
		my $retval = waitpid($$temp_array[0], &WNOHANG);
		if ($retval != 0) {
			close ($$temp_array[1]);
		} else {
			push(@new_children_list, $temp_array);
		}
	}
	@live_children = @new_children_list;
	logmessage(3, 'sub clean', 'ended');
	return (1);
}

################################################################################

sub main {
	logmessage(3, 'sub main', 'started');
	$SIG{CHLD} = sub {clean;};
	my $socket;	# Master socket
	my $new_sock;	# sub socket connections
	my $buf;	# received text
	my $bytes_read;  # characters read
	
	$socket = IO::Socket::INET->new(LocalAddr => '127.0.0.1',
					LocalPort => '5000',
					Listen => 5,
					Reuse => 1,
					Proto => 'tcp');
	
	unless ($socket) {print 'Unable to capture socket'; exit;}
	
	# Start looping for new connections.  The procedure clean is called to attempt
	# to remove children clients a second time.
	while (clean and $new_sock = $socket->accept()) {
		my $pid = fork;
		die "Cannot fork: $!" unless defined($pid);
		if ($pid == 0) { # I am a daughter
			logmessage(0, 'serve_http.pl child', 'New child spawned.');
			# Set daughter to kill herself if she gets too old
			$SIG{ALRM} = sub {logmessage(10, 'serve_http.pl child', 'timeout'); exit(1);};
			alarm($child_timeout);
			while (1) {
				$bytes_read = sysread($new_sock, $buf, 1);
				logmessage(5, 'child process', 'buffer char ascii value ' . unpack('C1', $buf));
				if ($bytes_read == 0) {
					# Socket closed
					logmessage(11, 'child process', 'socket closed');
					exit(0);
				} elsif(defined($bytes_read)) {
					$main_buffer .= $buf;
					$main_buffer_length++;
					# Print buffer into server window
					logmessage(5, 'child process buffer', "'$main_buffer'");
					# If command is understood, execute handler
					if (defined($messages{$main_buffer})) {
						&{$messages{$main_buffer}}($new_sock);
						$main_buffer = '';
						$main_buffer_length = 0;
					# If command is too long, clear buffer
					} elsif ($main_buffer_length >= $max_length) {
						unknown_command($new_sock);
						$main_buffer_length = 0;
						$main_buffer = '';
					# Eliminate obviously invalid commands
					} elsif ($main_buffer ne '') {
						my $unknown = 1;
						my $key;
						foreach $key (keys(%messages)) {
							if ($key =~ /^$main_buffer/) {
								$unknown = undef;
							}
						}
						if (defined($unknown)) {
							unknown_command($new_sock);
							$main_buffer_length = 0;
							$main_buffer = '';
						}
					}
				}
			}
		} else {
			push (@live_children, [$pid, $new_sock]);
		}
	}
	
	close ($socket);
	logmessage(3, 'sub main', 'ended');
}
logmessage(0, 'serve_http.pl', 'started');
main;
exit(0);