#!/usr/local/bin/perl -w
#-*- perl -*-
BEGIN{
    $ENV{PATH} = '/usr/ucb:/bin';
}
#--------------------------------------------------------------------
# 
#--------------------------------------------------------------------
use Socket;
use Carp;
use FileHandle;
#----------------------------------------------------------------------
# 
#----------------------------------------------------------------------
my $PORT = 2345;
my $PROG = 'echo ';
#----------------------------------------------------------------------
# ץ
#----------------------------------------------------------------------
while ($_ = shift @ARGV) {
    if (/^-p/)    { $PORT = shift @ARGV; next; }
#    if (/^-D/)    { $DEBUG_MODE = 1; next; }
    $PROG = $_;
}
#--------------------------------------------------------------------
# å
#--------------------------------------------------------------------
sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n"; }
#--------------------------------------------------------------------
# åȤ̿
#--------------------------------------------------------------------
sub SetupSocket {
    my $port = shift;
    my $proto = getprotobyname('tcp');
    # åȤ
    socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
    setsockopt(Server, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
	|| die "setsockopt: $!";
    # Х
    bind(Server, sockaddr_in($port, INADDR_ANY)) || die "bind: $!";
    # դ
    listen(Server, SOMAXCONN);

    select(Server); $| = 1; select(STDOUT);  # Хåե
}
#--------------------------------------------------------------------
# ᥤץ
#--------------------------------------------------------------------
sub MainProcess {
    my $prog = shift;
    my $key = <>; chomp $key;
    logmsg "$prog $key";
    exec "$prog $key";
}
#--------------------------------------------------------------------
# Multi-Thread Manager
#--------------------------------------------------------------------
sub spawn {
    my $coderef = shift;
    my $prog = shift;
    unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
	confess "usage: spawn CODEREF";
    }
    my $pid;
    if (!defined ($pid = fork)) {
	logmsg "cannot fork: $!";
	return;
    } elsif ($pid) {
	logmsg "begat $pid";
	return;			# parent process
    }
    # child process
    open(STDIN, "<&Client") || die "can't dup client to stdin";
    open(STDOUT, ">&Client") || die "can't dup client to stdout";
    STDOUT->autoflush();
#    Client->autoflush();
    exit &$coderef($prog);
}
#--------------------------------------------------------------------
# ᥤ롼
#--------------------------------------------------------------------
STDOUT->autoflush();
&SetupSocket($PORT);

my $waitedpid = 0;
my $addr;

logmsg "server started on port $PORT";

sub PEAPER {
    $waitedpid = wait;
    $SIG{CHLD} = \&PEAPER;
    logmsg "reaped $waitedpid" . ($? ? " with exit $?" : "");
}
$SIG{CHLD} = \&PEAPER;

for (; $addr = accept(Client, Server); close Client) {
    my ($port, $iaddr) = sockaddr_in($addr);
    my $name = gethostbyaddr($iaddr, AF_INET);

    $PNUM++;
    logmsg "($PNUM) connection from $name [", inet_ntoa($iaddr), "] at port $port";

    spawn (\&MainProcess,$PROG);
}
