# 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 $B$N(B port $BHV9f(B 11910 $B$N%5!<%P$r(B 4 $BBfJBNs$KF0$+$9!%(B(11910 $B$K%U%!%$%k$N(B
#|# $B%Q%9L>$r5-=R$9$k$H!"(BUNIX Domain Socket $B$GBT$A<u$1$^$9(B)
#|&switcher::launch(11910, 4, \&main,
#|                  'Proto' => 'tcp',
#|                  'Verbose' => 1);
#|# &switcher::launch $B$O(B SIGHUP $B$r<u$1<h$k$H!";R%W%m%;%9$r(B kill SIGTERM $B$7!"(B
#|# $B%j%?!<%s$7$^$9!#(B
#+-----------------------------------------------------------------------------
#
# Interfaces:
# &switcher::launch(PORT_OR_DOMAIN_PATH, NSERVERS, MAIN-ROUTINE
#		    [, Options [, ...]]);
# Options:
#    Proto	'tcp' - TCP $B@\B3(B ($B%G%U%)%k%H(B)
# 		'udp' - UDP $B@\B3(B
#    Start	fork $BD>8e$K(B 1 $BEY$@$18F$S=P$5$l$k4X?t(B
#    End	exit $BD>A0$K(B 1 $BEY$@$18F$S=P$5$l$k4X?t(B
#    Lockfile	$B%m%C%/%U%!%$%k$r;XDj!#(B
#    Daemon	$B??$NCM$r;XDj$9$k$H%P%C%/%0%i%&%s%I$GF0:n$9$k!#(B
#    Verbose	$B??$NCM$r;XDj$9$k$H>iD9%a%C%;!<%8$rI=<($9$k!#(B
#    RecvBufsiz	recv $B$G<u$1<h$k:GBg%P%$%H?t$r;XDj$9$k!#(B
#
# $switcher::sw_id
#	$B;R%5!<%PFCM-$N0l0U$J(B ID
# $switcher::version
#	switcher $B$N%P!<%8%g%s(B
# switcher::SW
#	TCP $B@\B3(B $B$K$*$$$F!"@\B3$5$l$?%=%1%C%H(B

# Change Logs
# Fri Dec 10 1999
# version 3 $B$r%j%j!<%9(B
# switcher $B%$%s%?!<%U%'!<%9$rJQ99(B
# &main::switcher $B$r(B &switcher::launch $B$HL>A0$rJQ99$7!"Bh(B 3 $B0z?t$K(B
# $B%a%$%s%k!<%A%s$r;XDj$9$k$h$&$K$7$?!#(B
# main::sw_start, main::sw_main, main::sw_end $B$rGQ;_!#(B
#
# Fri Jan 8 JST 1999
# version 2 $B$r%j%j!<%9(B
# UDP $B$b07$($k$h$&$K$7$?!#(B
# recv, accept $B$O>o$K%m%C%/$9$k$h$&$K$7$?!#(B
# switcher $B$K%*%W%7%g%s$r;XDj$G$-$k$h$&$K$7$?!#(B
#
# Tue Sep 23 1997
# $B%P%0%U%#%C%/%9(B
# 
# Mon Jan 20 1997
# SIGHUP $B$,$+$+$k$H!$(B$switcher::sighup_flag $B$r(B 1 $B$K$7$F!$(Bswitcher $B$+$i(B
# $BH4$1$k$h$&$K$7$?!%(B
# $lockfile $B$NDj5A$r(B main::switcher $B$NFbB&$KF~$l$?!%(B
#
# Sat Jan 11 1997
# Soralis 2.x $B$G$O!$(Baccept $B$r(B lock $B$7$J$$$H@5>oF0:n$7$J$$$H$$$&%P%0$r%U%#%C%/%9(B


########################
# 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;# $B;R%W%m%;%9$r=*N;$5$;$k$N$KI,MW(B
undef $main;	# $B%a%$%s%k!<%A%s(B
undef $start_servers; # $B%5!<%P?t(B

# 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;

    # $B%k!<%A%s$,Dj5A$5$l$F$$$k$+$I$&$+$N%A%'%C%/(B
    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 #
######################
