# switcher - perl switch server.
#
# Create: Thu Jan 09 1997
# Author: Masanao Izumo <mo@goice.co.jp>
# Version: 3.00
# Last Modify: Fri Dec 10 1999

##########
# Sample #
##########
#+-----------------------------------------------------------------------------
#|#!/usr/local/bin/perl
#|
#|require 'switcher.pl';
#|
#|sub main
#|{
#|    print switcher::SW "Hi there, this is server $switcher::sw_id. (PID = $$)\n";
#|    print switcher::SW "Connection file discripter number is ", fileno(switcher::SW), "\n";
#|    print switcher::SW "Good by\n";
#|}
#|
#|# TCP の port 番号 11910 のサーバを 4 台並列に動かす．(11910 にファイルの
#|# パス名を記述すると、UNIX Domain Socket で待ち受けます)
#|&switcher::launch(11910, 4, \&main,
#|                  'Proto' => 'tcp',
#|                  'Verbose' => 1);
#|# &switcher::launch は SIGHUP を受け取ると、子プロセスを kill SIGTERM し、
#|# リターンします。
#+-----------------------------------------------------------------------------
#
# Interfaces:
# &switcher::launch(PORT_OR_DOMAIN_PATH, NSERVERS, MAIN-ROUTINE
#		    [, Options [, ...]]);
# Options:
#    Proto	'tcp' - TCP 接続 (デフォルト)
# 		'udp' - UDP 接続
#    Start	fork 直後に 1 度だけ呼び出される関数
#    End	exit 直前に 1 度だけ呼び出される関数
#    Lockfile	ロックファイルを指定。
#    Daemon	真の値を指定するとバックグラウンドで動作する。
#    Verbose	真の値を指定すると冗長メッセージを表示する。
#    RecvBufsiz	recv で受け取る最大バイト数を指定する。
#
# $switcher::sw_id
#	子サーバ特有の一意な ID
# $switcher::version
#	switcher のバージョン
# switcher::SW
#	TCP 接続 において、接続されたソケット

# Change Logs
# Fri Dec 10 1999
# version 3 をリリース
# switcher インターフェースを変更
# &main::switcher を &switcher::launch と名前を変更し、第 3 引数に
# メインルーチンを指定するようにした。
# main::sw_start, main::sw_main, main::sw_end を廃止。
#
# Fri Jan 8 JST 1999
# version 2 をリリース
# UDP も扱えるようにした。
# recv, accept は常にロックするようにした。
# switcher にオプションを指定できるようにした。
#
# Tue Sep 23 1997
# バグフィックス
# 
# Mon Jan 20 1997
# SIGHUP がかかると，$switcher::sighup_flag を 1 にして，switcher から
# 抜けるようにした．
# $lockfile の定義を main::switcher の内側に入れた．
#
# Sat Jan 11 1997
# Soralis 2.x では，accept を lock しないと正常動作しないというバグをフィックス


########################
# start of switcher.pl #
########################
package switcher;

use Socket;
use POSIX unistd_h; # for setsid

$version = '3.00';
$sighup_flag = 0;
undef $verbose;
undef %opt;
sub nop {}
$is_tcp = 1;
$recvbufsiz = 65536;
undef @pid_list;# 子プロセスを終了させるのに必要
undef $main;	# メインルーチン
undef $start_servers; # サーバ数

# See manual page for `flock(2)' for following definitions.
$LOCK_SH ||= 1;
$LOCK_EX ||= 2;
$LOCK_NB ||= 4;
$LOCK_UN ||= 8;

sub launch
{
    my($port) = shift;
    $start_servers = shift;
    $main = shift;
    %opt = @_;

    $sighup_flag = 0;

    $verbose = $opt{'Verbose'};
    $recvbufsiz = $opt{'RecvBufsiz'} || $recvbufsiz;

    # ルーチンが定義されているかどうかのチェック
    if(!defined &{$main}) {
	die "$main is not defined\n";
    }
    if(exists $opt{'Start'}) {
	if(!defined &{$opt{'Start'}}) {
	    die "$opt{'Start'} is not defined\n";
	}
    } else {
	$opt{'Start'} = \&nop;
    }
    if(exists $opt{'End'}) {
	if(!defined &{$opt{'End'}}) {
	    die "$opt{'End'} is not defined\n";
	}
    } else {
	$opt{'End'} = \&nop;
    }

    $opt{'Proto'} ||= 'tcp';
    $lockfile = $opt{'Lockfile'} || $lockfile || "switcher-lock.$$";

    # check whether lock file can open.
    open(LOCK, ">$lockfile") || die "$lockfile: $!\n";
    close(LOCK);

    $start_servers || ($start_servers = 1);
    &socket_init($port, $opt{'Proto'});

    if($opt{'Daemon'}) {
	exit if fork;
        &POSIX::setsid();
    }
    $ppid = getpid;
    print STDERR "$ppid: parent\n" if $verbose;
    $SIG{'INT'}  = \&parent_sigterm;
    $SIG{'TERM'} = \&parent_sigterm;
    $SIG{'HUP'}  = \&parent_sighup;

    for(0 .. $start_servers - 1) { &make_child($_); };

    &parent_main;		# Loop until receive SIGHUP.

    unlink($lockfile);
    close(LOCK);
    close(SOCK);
}

sub socket_init
{
    my($port, $proto) = @_;
    my($addr);

    $is_tcp = ($proto ne 'udp');

    if($is_tcp) {
	$proto = getprotobyname('tcp');
	if("$port" =~ /^\d+$/)
	{
	    $addr = sockaddr_in($port, INADDR_ANY);
	    socket(SOCK, PF_INET, SOCK_STREAM, $proto)
		|| die "socket: $!\n";
	    setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, 1);
	    $af_unix_path = undef;
	}
	else
	{
	    $addr = sockaddr_un($port);
	    socket(SOCK, AF_UNIX, SOCK_STREAM, 0) || die "socket: $!\n";
	    unlink($port);
	    $af_unix_path = $port;
	}

	bind(SOCK, $addr) || die "bind: $!\n";
	listen(SOCK, SOMAXCONN);
    } else {
	$proto = getprotobyname('udp');
	if("$port" =~ /^\d+$/)
	{
	    $addr = sockaddr_in($port, INADDR_ANY);
	    socket(SOCK, PF_INET, SOCK_DGRAM, $proto)
		|| die "socket: $!\n";
	    setsockopt(SOCK, SOL_SOCKET, SO_REUSEADDR, 1);
	    $af_unix_path = undef;
	}
	else
	{
	    $addr = sockaddr_un($port);
	    socket(SOCK, AF_UNIX, SOCK_DGRAM, 0) || die "socket: $!";
	    unlink($port);
	    $af_unix_path = $port;
	}
	bind(SOCK, $addr) || die "bind: $!\n";
	$udp_interface = $addr;
    }
}

sub make_child
{
    my($id) = @_;
    my($pid);

    $pid = fork;
    if(!defined $pid)
    {
	print STDERR "fork: $!\n";
	&parent_exit;
    }

    if($pid == 0) # child
    {
	$SIG{'INT'}  = 'IGNORE';
	$SIG{'PIPE'} = 'IGNORE';
	$SIG{'TERM'} = 'switcher::child_sigterm';
	$SIG{'HUP'}  = 'switcher::child_sighup';

	print STDERR "Run $id/", $start_servers-1, " (PID = $$)\n" if $verbose;
	$sw_id = $id;
	&child_main;
	# NOT REACHED;
    }
    $pid_list[$id] = $pid;
}

sub child_main
{
    local($from);

    sleep(1);
    open(LOCK, ">>$lockfile") || die "$lockfile: $!\n";
    &{$opt{'Start'}};
    select((select(SW), $| = 1)[0]);

    if($is_tcp) {
	while(1) {
	    flock(LOCK, $LOCK_EX);
#	    &child_exit if getppid != $ppid; # for safety
	    $from = accept(SW, SOCK) || die "accept: $!\n";
	    flock(LOCK, $LOCK_UN);
	    &$main;
	    close(SW);
	}
    } else {
	local($recvbuf);
	while(1) {
	    flock(LOCK, $LOCK_EX);
#	    &child_exit if getppid != $ppid; # for safety
	    ($from = recv(SOCK, $recvbuf, $recvbufsiz, 0)) || die "recv: $!\n";
	    flock(LOCK, $LOCK_UN);
	    &{$main}(*recvbuf);
	}
    }
}

sub parent_main
{
    my($pid);

    while(!$sighup_flag)
    {
	$pid = wait;
	next if $pid <= 0;
	
	for($[ .. $#pid_list)
	{
	    if($pid_list[$_] == $pid && !$sighup_flag)
	    {
		&make_child($_);
		last;
	    }
	}
    }
}

sub child_exit
{
    print STDERR "$$: exit\n" if $verbose;
    &{$opt{'End'}};
    exit 0;
}

sub child_sigterm
{
    my($sig) = @_;
    print STDERR "$$: Catch $sig\n" if $verbose;
    &child_exit;
}

sub child_sighup
{
    my($sig) = @_;
    print STDERR "$$: Child Catch $sig\n" if $verbose;
    kill(SIGHUP, getppid);
}

sub parent_sighup
{
    my($sig) = @_;
    print STDERR "$$: Parent Catch $sig\n" if $verbose;
    kill(SIGTERM, @pid_list);
    $sighup_flag = 1;
}

sub parent_exit
{
    kill(SIGTERM, @pid_list);
    close(LOCK);
    unlink($lockfile);
    close(SOCK);
    unlink($af_unix_path) if defined $af_unix_path;
    exit 0;
}

sub parent_sigterm
{
    my($sig) = @_;
    print STDERR "$$: Catch $sig\n" if $verbose;
    &parent_exit;
}

1;
######################
# end of switcher.pl #
######################