#!/usr/bin/perl -w
use strict;
use IO::Socket::INET ;
use Fcntl ':flock';
use Fcntl ':seek' ;

my($max_log_rec_size) = 100 ;
my($max_client_name_size) = 50 ;
my($max_message_size) = $max_log_rec_size - $max_client_name_size - 4 ;

sub write_log {
    my ($outFile, $clnt_name, $log_msg) = @_ ;
    
    if (length($log_msg) > $max_log_rec_size) {
        $log_msg = substr($log_msg, $max_log_rec_size) ;
    }
    my $wrz = sprintf("%-*s -- %s\n", $max_client_name_size,
                      $clnt_name, $log_msg) ;
    flock ($outFile, LOCK_EX) ;
    seek ($outFile, 0, SEEK_END) ;
    print $outFile $wrz ;
    flock ($outFile, LOCK_UN) ;
}

sub logServerAction {
    my ($outFile, $clnt_name, $log_msg) = @_ ;
    write_log ($outFile, $clnt_name, '*** ' . $log_msg . ' ***') ;
}

sub hexIt {
    substr ('0123456789ABCDEF', $_[0] & 0xF, 1) ;
}

sub logClientInput {
    my ($logFile, $clnt_name, $user_rsp) = @_ ;
    my $outBuff = '"' ;
    for (my $userP=0; $userP < length($user_rsp) && length($outBuff)<($max_message_size-4); ++$userP) {
        my $nextC = substr($user_rsp, $userP, 1) ;
        if ($nextC eq "\r") {
            $outBuff .= "\\r" ;
        } elsif ($nextC eq "\n") {
            $outBuff .= "\\n" ;
        } elsif ($nextC eq "\0") {
            $outBuff .= "\\0" ;
        } elsif ($nextC eq "\\") {
            $outBuff .= "\\\\" ;
	} elsif ($nextC ge '0' && $nextC le '9') {
	    $outBuff .= '#' ;
        } elsif ($nextC ge ' ' && $nextC le '~') {
            $outBuff .= $nextC ;
        } else {
            $outBuff .= ( "\\x" . &hexIt(ord($nextC) >> 4) . &hexIt(ord($nextC)) ) ;
        }
    }
    if (length($outBuff) < ($max_message_size-4)) {
        $outBuff .= '"' ;
    }
    write_log($logFile, $clnt_name, $outBuff) ;
}

sub readLine {
    my ($sio, $pLineBuff, $lineSize, $timeLimit) = @_ ;
    my $alarmtime = time() + $timeLimit + 1;   
    my $lineRead = 0 ;
    $$pLineBuff = '' ;
    while ($lineRead < $lineSize &&
           (($lineRead < 1) || substr($$pLineBuff, $lineRead-1, 1) ne "\n")) {
        my $sio0n = '' ;
        vec($sio0n, fileno($sio), 1) = 1 ;
        my $selLimit = $alarmtime - time() ;
        my $numReady = select($sio0n, undef, undef, $selLimit) ;
        if ($numReady == 0) {
            return -1 ;
        }
        my $rc = sysread($sio, $$pLineBuff, $lineSize - $lineRead, $lineRead) ;
        if ($rc < 0) {
            return -1 ;
        } elsif ($rc == 0) {
            return $lineRead ;
        }
        $lineRead += $rc ;
    }
    return $lineRead ;
}        

sub process_request {
    my ($logFile, $sio) = @_ ;
    my $clnt_name = gethostbyaddr($sio->peeraddr(), AF_INET) ;
    &logServerAction($logFile, $clnt_name, 'connected') ;
    my $outBuff = '' ;
    if (&readLine($sio, \$outBuff, 1024, 10) >= 0) {
        &logClientInput($logFile, $clnt_name, $outBuff) ;
        &logServerAction($logFile, $clnt_name, 'exited') ;
    } else {
        &logServerAction($logFile, $clnt_name, 'killed') ;
    }
    close($sio) ;
}

my $logFileName = 'h1.log' ;
if ( $#ARGV >= 0) {
    $logFileName = $ARGV[0] ;
}

my $logFile ;
if (!open($logFile, ">${logFileName}")) {
    print STDERR "Unable to open ${logFileName}\n" ;
    exit 1 ;
}

my $serverport = 3630 ;
my $rendezvous = IO::Socket::INET->new(
        Listen    => 5,
        LocalPort => $serverport,
        Proto     => 'tcp') ;

die "Unable to bind tcp port ${serverport}: $!" unless $rendezvous ;

$SIG{CHLD} = 'IGNORE' ;
while (1) {
    my $sio = $rendezvous->accept() ;
    die "Unable to accept: $!" unless $sio ;
    if (fork() > 0) {
        close($sio) ;
    } else {
        close($rendezvous) ;
        &process_request($logFile, $sio) ;
        exit 0 ;
    }
}