#!/usr/bin/perl

package PerlSvc;

use strict;
use IO::Socket;
use IO::Select;
use Symbol;
require Getopt::Long;

#########################################################################
#STARS Server
$PerlSvc::Version='
Version: 2 
$Revision: 1.1 $
$Date: 2010/01/19 02:43:50 $

';
# Takashi Kosuge
#########################################################################
#Setting for system
$PerlSvc::Port                =  6057;
$PerlSvc::LibDir              =  'takaserv-lib/';
$PerlSvc::KeyDir              =  '';
use constant RNDMAX      => 10000;
use constant HOSTLIST    => 'allow.cfg';
use constant ALIASES     => 'aliases.cfg';
use constant CMDDENY     => 'command_deny.cfg';
use constant CMDALLOW    => 'command_allow.cfg';
# Add 2 lines for Reconnectable function. 2008/3/6
use constant RECONNECTABLEDENY     => 'reconnectable_deny.cfg';
use constant RECONNECTABLEALLOW    => 'reconnectable_allow.cfg';
#########################################################################

######### ONLY DEVELOP ##########
$::Debug=1; 
######### ONLY DEVELOP ##########

$PerlSvc::Version=~s/(\n|\r|\$)//g;

##WinSVC##
%PerlSvc::Config = (ServiceName => "takaserv");

##WinSVC##

%PerlSvc::Node=();        #node name and file handle, name is key, handle is value
%PerlSvc::NodeH=();       #file handle and node name, handle is key, name is value
%PerlSvc::NodeBuf=();     #node input buffer
%PerlSvc::NodeFlgOn=();   #node list which sends event message to this node
%PerlSvc::NodeIDKey =();  #KeyNumber from server
%PerlSvc::AliasReal =();  #alias list, key is aliase
%PerlSvc::RealAlias =();  #alias list, key is real name
@PerlSvc::CmdDeny=();     #Command deny list with RegEx
@PerlSvc::CmdAllow=();    #Command allow list with RegEx

$PerlSvc::Xfh;            #Handle for printing
$PerlSvc::Xbuf;           #Buffer for printing
$PerlSvc::readable;       #Used by select in main loop

# Add 2 lines for Reconnectable function. 2008/3/6
@PerlSvc::ReconnectableDeny=();     #Reconnectable deny list with RegEx
@PerlSvc::ReconnectableAllow=();    #Reconnectable allow list with RegEx


unless (defined &ContinueRun) {
	*ContinueRun      = sub { return 1 };
	*RunningAsService = sub { return 0 };
	Interactive();
}

exit(0);

sub Interactive{
	Install();
	Startup();
}

sub Install{
	Getopt::Long::GetOptions(
	'service=s'  => \$PerlSvc::Config{ServiceName},
	'port=i'     => \$PerlSvc::Port,
	'lib=s'      => \$PerlSvc::LibDir,
	'key=s'      => \$PerlSvc::KeyDir,
	'h'          => \&usage
	);

    $PerlSvc::Config{DisplayName} = "$PerlSvc::Config{ServiceName} STARS Server Service";
	$PerlSvc::Config{Parameters}  = "--p $PerlSvc::Port --lib $PerlSvc::LibDir --key $PerlSvc::KeyDir";
}


# Print usage. ---------------------------------------------
sub usage{
## Todo: Please modify help message for "-h" option.
  print "STARS Server $PerlSvc::Version\n";
  print "Usage: $0 [-h] [-port ServerPort] [-lib LibDir] [-key KeyDir]\n";
  print "          [-service ServiceName]\n\n";
  print "You are able to run STARS server as service with Windows.\n";
  print "Install and run as service:\n";
  print "   $0 --install auto -lib LibDir\n";
  print "Remove service:\n";
  print "   $0 --remove\n\n";
  print "If your OS is FreeBSD, Linux etc., you are able to run STARS server on\n";
  print " back ground.\n";
  print "   ./$0 &\n";
  exit(0);
}



###=============================================================
sub Startup{

	Getopt::Long::GetOptions(
	'port=i'     => \$PerlSvc::Port,
	'lib=s'      => \$PerlSvc::LibDir,
	'key=s'      => \$PerlSvc::KeyDir
	);

	unless($PerlSvc::LibDir =~ /\/$/){$PerlSvc::LibDir .= '/';}
	if($PerlSvc::KeyDir eq ''){$PerlSvc::KeyDir=$PerlSvc::LibDir;}
	unless($PerlSvc::KeyDir =~ /\/$/){$PerlSvc::KeyDir .= '/';}


	my $new_sock;
	my $bufhn;
	my $ipadr;
	my $fromnode;
	my $tonode;
	my $buf;
	my $ready;
	my $s;

##Initialize
	srand(time() ^ ($$ + ($$ <<15)) );
	system_loadcommandpermission();
	system_loadaliases();
	
	# Add a line for Reconnectable function. 2008/3/6
	system_loadreconnectablepermission();

	my $listener = 
	      IO::Socket::INET->new(
	        LocalPort => $PerlSvc::Port, Proto => 'tcp', Listen => 5, Reuse => 1 );
	    die "Can't create socket for listening: $!" unless $listener;

	$PerlSvc::readable = IO::Select->new;     # Create a new IO::Select object
	$PerlSvc::readable->add($listener);          # Add the listener to it


#--main---
	while(ContinueRun()) {
		($ready) = IO::Select->select($PerlSvc::readable, undef, undef, 2);
		foreach $s (@$ready) {
			if($s == $listener) {
				$new_sock = $listener->accept;
				if($new_sock){
					select($new_sock);$|=1;select(STDOUT);
					$PerlSvc::readable->add($new_sock);
					$bufhn = system_gethostname($new_sock);
				    $ipadr = system_gethostaddr($new_sock);
					unless(system_checkhost($PerlSvc::LibDir.HOSTLIST, $bufhn, $ipadr, 0)){
						printh($new_sock, "Bad host. $bufhn\n");
						$PerlSvc::readable->remove($new_sock);
						$new_sock->close;
					}
					$PerlSvc::NodeBuf{$new_sock}='';
					$PerlSvc::NodeIDKey{$new_sock}=get_nodeidkey();
					printh($new_sock,$PerlSvc::NodeIDKey{$new_sock}."\n");
				}
			} else {  # It is an established connection
				if( sysread($s,$buf,512) ){
					$PerlSvc::NodeBuf{$s} .= $buf;
					while($PerlSvc::NodeBuf{$s} =~ s/([^\r\n]*)\r*\n//){
						$buf=$1;
						if ($buf =~ /^(exit|quit)$/i) {
							delnode($s);
							$PerlSvc::readable->remove($s);
							$s->close;
						} elsif(exists $PerlSvc::NodeH{$s}){
							sendmes($s,"$buf");
						} else {
							unless(addnode($s,"$buf")){
								delete $PerlSvc::NodeBuf{$s};
								delete $PerlSvc::NodeIDKey{$s};
								$PerlSvc::readable->remove($s);
								$s->close;
							}
						}
					}
				} else { # The client disconnected.
					delnode($s);
					$PerlSvc::readable->remove($s);
					$s->close;
				}
			}
		}
	}
	return(0);
}


#Check host for node-----------------------------------------------------
sub check_term_and_host{
	my $nd=shift; #nodename
	my $hd=shift; #handle

	if($::Debug){
		print "check_term_and_host I am node $nd\n";
	}
	unless(-e $PerlSvc::KeyDir.$nd.'.allow'){
		if($::Debug){
			print "check_term_and_host not_found_ok $PerlSvc::KeyDir.$nd.allow\n";
		}
		return(1);
	}
	if(system_checkhost($PerlSvc::KeyDir.$nd.'.allow', system_gethostname($hd), system_gethostaddr($hd),1)){
		return(1);
	}
	return(0);
}

#Check Node Key---------------------------------------------------------------
sub check_nodekey{
	my $nname=shift;
	my $nkeynum=shift;
	my $nkeyval=shift;

	my $kcount=0;
	my $lp;

	my $hd = gensym();
	open($hd, $PerlSvc::KeyDir."$nname.key") or return('');
	while(<$hd>){$kcount++;}
	unless($kcount){close($hd); return('');}
	$kcount = $nkeynum % $kcount;
	seek($hd, 0, 0);
	for($lp=0; $lp < $kcount; $lp++){$_=<$hd>;}
	$_=<$hd>;
	chomp;s/\r//;
	close($hd);
	if($_ eq $nkeyval){return(1);}
	return('');
}

#Make Idkey-------------------------------------------------------------------
sub get_nodeidkey{
 return( int(rand RNDMAX) );
}


#Print-------------------------------------------------------------------------
sub printh{
	($PerlSvc::Xfh,$PerlSvc::Xbuf) = @_;
	print $PerlSvc::Xfh "$PerlSvc::Xbuf";
	if(defined $PerlSvc::Node{'Debugger'}){
		my $handle=$PerlSvc::Node{'Debugger'};
		print $handle "$PerlSvc::Xbuf";
	}
	if(defined $PerlSvc::Node{'Debugger0'}){
	    my $handle=$PerlSvc::Node{'Debugger0'};
	    print $handle "$PerlSvc::Xbuf";
	}
	if(defined $PerlSvc::Node{'Debugger1'}){
	    my $handle=$PerlSvc::Node{'Debugger1'};
	    print $handle "$PerlSvc::Xbuf";
	}
	if(defined $PerlSvc::Node{'Debugger2'}){
	    my $handle=$PerlSvc::Node{'Debugger2'};
	    print $handle "$PerlSvc::Xbuf";
	}
	if(defined $PerlSvc::Node{'Debugger3'}){
	    my $handle=$PerlSvc::Node{'Debugger3'};
	    print $handle "$PerlSvc::Xbuf";
	}
	if(defined $PerlSvc::Node{'Debugger4'}){
	    my $handle=$PerlSvc::Node{'Debugger4'};
	    print $handle "$PerlSvc::Xbuf";
	}
}

#-----------------------------------------------------------------------------
sub sendmes{
	my($handle,$buf)=@_;
	my $tonode;
	my $tonodes;
	my $tonodeh;
	my $fromnodes;
	my $fromnode = $fromnodes = $PerlSvc::NodeH{$handle};

	if($buf =~ s/^([a-zA-Z_0-9.\-]+)>//){
		$fromnode=$1;
	}
	unless($buf =~ s/^([a-zA-Z_0-9.\-]+)\s*//){
		printh($handle, "System>$fromnode> \@\n");
		return(1);
	}
	$tonodes = $1;
	if(defined $PerlSvc::AliasReal{$tonodes}){
		$tonodes = $PerlSvc::AliasReal{$tonodes};
	}
	if($buf =~ /^[^@]/ and
		( (@PerlSvc::CmdDeny and isDenyCheckCmdDeny($fromnodes, $tonodes, $buf))
		or (@PerlSvc::CmdAllow and isDenyCheckCmdAllow($fromnodes, $tonodes, $buf)) ) ){
		if($buf =~ /^[^_]/){
			printh($handle, "System>$fromnode \@$buf Er: Command denied.\n");
		}
		return('');
	}
	$tonode = $tonodes;
	$tonode =~ s/\..*//;
	if($tonode eq 'System'){
		return system_commands($handle,$fromnode,"$buf");
	}
	unless(exists $PerlSvc::Node{$tonode}){
		unless($buf =~ /^[_@]/){
			printh($handle, "System>$fromnode \@$buf Er: $tonode is down.\n");
		}
		return('');
	}

	if(defined $PerlSvc::RealAlias{$fromnode}){
		$fromnode=$PerlSvc::RealAlias{$fromnode};
	}

	$tonodeh=$PerlSvc::Node{$tonode};
	printh($tonodeh,  "$fromnode>$tonodes $buf\n");
	return(1);
}

sub isDenyCheckCmdDeny{
	my ($from, $to, $buf) = @_;
	my $chk;
	unless($buf =~ /^(\S+)( |$)/){return(1);}
	$buf = "$from>$to $1";
	for $chk (@PerlSvc::CmdDeny){
		if($buf =~ /$chk/){return(1);}
	}
	return(0);
}

sub isDenyCheckCmdAllow{
	my ($from, $to, $buf) = @_;
	my $chk;
	unless($buf =~ /^(\S+)( |$)/){return(1);}
	$buf = "$from>$to $1";
	for $chk (@PerlSvc::CmdAllow){
		if($buf =~ /$chk/){return(0);}
	}
	return(1);
}

# Add new function for Reconnectable function. 2008/3/6
sub isDenyCheckReconnectableDeny{
	my ($node, $host) = @_;
	my $chk;
	for $chk (@PerlSvc::ReconnectableDeny){
		if(($chk =~ /^$node\s+$host$/) or ($chk =~ /^$node$/)){return(1);}
	}
	return(0);
}

# Add new function for Reconnectable function. 2008/3/6
sub isDenyCheckReconnectableAllow{
	my ($node, $host) = @_;
	my $chk;
	for $chk (@PerlSvc::ReconnectableAllow){
		if(($chk =~ /^$node\s+$host$/) or ($chk =~ /^$node$/)){return(0);}
	}
	return(1);
}

#------System Commands--------------------------------------------------
sub system_commands{
	my ($hd,$frn,$cmd) = @_;
		if($cmd =~ /^_/){
			system_event($frn,$cmd);
		}elsif($cmd =~ s/^disconnect //){
			system_disconnect($hd,$frn,$cmd);
		}elsif($cmd =~ s/^flgon //){
			system_flgon($hd,$frn,$cmd);
		}elsif($cmd =~ s/^flgoff //){
			system_flgoff($hd,$frn,$cmd);
# Add 3 lines for Reconnectable function. 2008/3/6
		}elsif($cmd eq 'loadreconnectablepermission'){
			system_loadreconnectablepermission();
			printh($hd, "System>$frn \@loadreconnectablepermission Reconnectable permission list has been loaded.\n");
		}elsif($cmd eq 'loadpermission'){
			system_loadcommandpermission();
			printh($hd, "System>$frn \@loadpermission Command permission list has been loaded.\n");
		}elsif($cmd eq 'loadaliases'){
			system_loadaliases();
			printh($hd, "System>$frn \@loadaliases Aliases has been loaded.\n");
		}elsif($cmd eq 'listaliases'){
			printh($hd, "System>$frn \@listaliases ".system_listaliases()."\n");
		}elsif($cmd eq 'listnodes'){
			printh($hd, "System>$frn \@listnodes ".system_listnodes()."\n");
		}elsif($cmd eq 'gettime'){
			printh($hd, "System>$frn \@gettime ".system_gettime()."\n");
		}elsif($cmd eq 'hello'){
			printh($hd, "System>$frn \@hello Nice to meet you.\n");
		}elsif($cmd eq 'getversion'){
			printh($hd, "System>$frn \@getversion $PerlSvc::Version\n");
		}elsif($cmd eq 'help'){
# Comment a line for Reconnectable function. 2008/3/6
#			printh($hd, "System>$frn \@help flgon flgoff loadaliases listaliases loadpermission listnodes gettime hello getversion disconnect\n");
# Add a line for Reconnectable function. 2008/3/6
			printh($hd, "System>$frn \@help flgon flgoff loadaliases listaliases loadpermission loadreconnectablepermission listnodes gettime hello getversion disconnect\n");
		}elsif($cmd =~ /^\@/){
			return(1);
		}else{
			printh($hd, "System>$frn \@$cmd Er: Command is not found or parameter is not enough.\n");
		}
		return(1);
}

sub system_event{
	my ($frn,$cmd) = @_;
	my $to;
	my $topre;
	if(defined $PerlSvc::RealAlias{$frn}){$frn = $PerlSvc::RealAlias{$frn};}
	my $buffh;
	foreach (keys(%PerlSvc::NodeFlgOn)){
		if($PerlSvc::NodeFlgOn{$_} =~ / $frn /){
			$to = $topre = $_;
			$topre =~ s/\..*//;
			$buffh = $PerlSvc::Node{$topre};
			printh($buffh, "$frn>$to $cmd\n");
		}
	}
}

sub system_disconnect{
	my ($hd,$frn,$cmd) = @_;
	my $node;
	my $dhandle;
	unless($cmd =~ /^([a-zA-Z_0-9.\-]+)/){
		printh($hd, "System>$frn \@disconnect Er: Parameter is not enough.\n");
		return('');
	}
	$cmd = $1;
	if(defined $PerlSvc::AliasReal{$cmd}){
		$cmd = $PerlSvc::AliasReal{$cmd};
	}
	unless(defined $PerlSvc::Node{$cmd}){
		printh($hd, "System>$frn \@disconnect Er: Node $cmd is down.\n");
		return('');
	}
	$dhandle = $PerlSvc::Node{$cmd};



	printh($hd, "System>$frn \@disconnect $cmd.\n");
	delnode($dhandle);
	$PerlSvc::readable->remove($dhandle);
	$dhandle->close;

	return(1);
}

sub system_flgon{
	my ($hd,$frn,$cmd) = @_;
	unless($cmd =~ /^([a-zA-Z_0-9.\-]+)/){
		printh($hd, "System>$frn \@flgon Er: Parameter is not enough.\n");
		return('');
	}
	$cmd = $1;
	if(defined $PerlSvc::NodeFlgOn{$frn}){
		if($PerlSvc::NodeFlgOn{$frn} =~ / $cmd /){
			printh($hd, "System>$frn \@flgon Er: Node $cmd is already in the list.\n");
			return('');
		}
		$PerlSvc::NodeFlgOn{$frn} .= " $cmd ";
		printh($hd, "System>$frn \@flgon Node $cmd has been registered.\n");
		return(1);
	}
	$PerlSvc::NodeFlgOn{$frn} = " $cmd ";
	printh($hd, "System>$frn \@flgon Node $cmd has been registered.\n");
	return(1);
}

sub system_flgoff{
	my ($hd,$frn,$cmd) = @_;
	unless($cmd =~ /^([a-zA-Z_0-9.\-]+)/){
		printh($hd, "System>$frn \@flgoff Er: Parameter is not enough.\n");
		return('');
	}
	$cmd = $1;
	unless(defined $PerlSvc::NodeFlgOn{$frn}){
		printh($hd, "System>$frn \@flgoff Er: List is void.\n");
		return('');
	}
	unless($PerlSvc::NodeFlgOn{$frn} =~ s/ $cmd //){
		printh($hd, "System>$frn \@flgoff Er: Node $cmd is not in the list.\n");
		return('');
	}
	unless($PerlSvc::NodeFlgOn{$frn}){
		delete $PerlSvc::NodeFlgOn{$frn};
	}
	printh($hd, "System>$frn \@flgoff Node $cmd has been removed.\n");
	return(1);
}

sub system_listaliases{
	my $buf='';
	my $lp;
	foreach $lp (keys(%PerlSvc::AliasReal)){
		$buf .= " $lp,".$PerlSvc::AliasReal{$lp};
	}
	return($buf);
}

sub system_listnodes{
	return(join(" ",keys(%PerlSvc::Node)));
}

sub system_gettime{
my $tm = shift(@_);
if($tm eq ''){$tm=time();}
my @tt = localtime($tm);
return(sprintf("%04d-%02d-%02d %02d:%02d:%02d",
$tt[5]+1900,$tt[4]+1,$tt[3],$tt[2],$tt[1],$tt[0]));
}

# Add new function for Reconnectable function. 2008/3/6
sub check_Reconnectable{
	my ($node, $hd) = @_;

	if(!(@PerlSvc::ReconnectableDeny) and !(@PerlSvc::ReconnectableAllow)){
		return(0);
	}

	if((@PerlSvc::ReconnectableDeny and isDenyCheckReconnectableDeny($node, system_gethostname($hd)))
		or (@PerlSvc::ReconnectableAllow and isDenyCheckReconnectableAllow($node, system_gethostname($hd)))){
		return(0);
	}
	return(1);
}

# Add new function for Reconnectable function. 2008/3/6
# Modify from sub system_disconnect Function.
sub disconnect_for_Reconnect{
	my ($node) = @_;  #This is Real node.
	my $cmd;
	my $dhandle;

	$cmd=$node;
	$dhandle = $PerlSvc::Node{$cmd};

	delnode($dhandle);
	$PerlSvc::readable->remove($dhandle);
	$dhandle->close;

	return(1);
}

#-----------------------------------------------------------------------
sub addnode{
	my($handle,$buff) = @_;
	my $buffh;
	my($node,$idmess)=split(/\s+/,$buff);
	my $to;
	my $topre;

# Add a line for Reconnectable function. 2008/3/6
	my $reconnectflag=0;
	
	if(exists $PerlSvc::Node{$node}){
# Comment 2 lines for Reconnectable function. 2008/3/6
#		printh($handle, "System> Er: $node already exists.\n");
#		return('');

# Add 6 lines for Reconnectable function. 2008/3/6
		unless(check_Reconnectable($node, $handle)){
			printh($handle, "System> Er: $node already exists.\n");
			return('');
		}else{
			$reconnectflag=1;
		}
	}
	unless(check_term_and_host($node,$handle)){
		printh($handle, "System> Er: Bad host for $node\n");
		return('');
	}
	unless(check_nodekey($node,$PerlSvc::NodeIDKey{$handle},$idmess)){
		printh($handle, "System> Er: Bad node name[$node] or key\n");
		return('');
	}

# Add 3 lines for Reconnectable function. 2008/3/6
	if($reconnectflag){
		disconnect_for_Reconnect($node);
	}
	
	$PerlSvc::Node{$node} = $handle;
	$PerlSvc::NodeH{$handle} = $node;
	printh($handle, "System>$node Ok:\n");

#Send connected messge to listening nodes
	if(defined $PerlSvc::RealAlias{$node}){$node = $PerlSvc::RealAlias{$node};}
	foreach (keys(%PerlSvc::NodeFlgOn)){
		if($PerlSvc::NodeFlgOn{$_} =~ / $node /){
			$to = $topre = $_;
			$topre =~ s/\..*//;
			$buffh = $PerlSvc::Node{$topre};
			printh($buffh, "$node>$_ _Connected\n");
		}
	}
	return(1);
}

sub delnode{
	my $handle = shift(@_);
	my $buffh;
	my $node = $PerlSvc::NodeH{$handle};
	my $lp;
	my $to;
	my $topre;

# reset my self
	delete $PerlSvc::NodeH{$handle};
	delete $PerlSvc::Node{$node};
	delete $PerlSvc::NodeBuf{$handle};
	delete $PerlSvc::NodeIDKey{$handle};
	for $lp (grep(/^$node($|\.)/, keys(%PerlSvc::NodeFlgOn))){
		delete $PerlSvc::NodeFlgOn{$lp};
	}

# Send disconnected messge to listening nodes
	if(defined $PerlSvc::RealAlias{$node}){$node = $PerlSvc::RealAlias{$node};}
	foreach (keys(%PerlSvc::NodeFlgOn)){
		if($PerlSvc::NodeFlgOn{$_} =~ / $node /){
			$to = $topre = $_;
			$topre =~ s/\..*//;
			$buffh = $PerlSvc::Node{$topre};
			printh($buffh, "$node>$_ _Disconnected\n");
		}
	}
}

# Add new function for Reconnectable function. 2008/3/6
#------ Set reconnectable permission  ------------------------
sub system_loadreconnectablepermission{
	@PerlSvc::ReconnectableDeny =();
	@PerlSvc::ReconnectableAllow =();

	my $RD = gensym();
	open($RD,$PerlSvc::LibDir.RECONNECTABLEDENY);
	while(<$RD>){
		if(/^#/){next;}
		chomp;s/\r//;
		if($_ eq ''){next;}
		push(@PerlSvc::ReconnectableDeny, $_);
	}
	close($RD);

	open($RD,$PerlSvc::LibDir.RECONNECTABLEALLOW);
	while(<$RD>){
		if(/^#/){next;}
		chomp;s/\r//;
		if($_ eq ''){next;}
		push(@PerlSvc::ReconnectableAllow, $_);
	}
	close($RD);

	return(1);
}

#------ Set Command permission  ------------------------
sub system_loadcommandpermission{
	@PerlSvc::CmdDeny =();
	@PerlSvc::CmdAllow =();

	my $RD = gensym();
	open($RD,$PerlSvc::LibDir.CMDDENY);
	while(<$RD>){
		if(/^#/){next;}
		chomp;s/\r//;
		if($_ eq ''){next;}
		push(@PerlSvc::CmdDeny, $_);
	}
	close($RD);

	open($RD,$PerlSvc::LibDir.CMDALLOW);
	while(<$RD>){
		if(/^#/){next;}
		chomp;s/\r//;
		if($_ eq ''){next;}
		push(@PerlSvc::CmdAllow, $_);
	}
	close($RD);

	return(1);
}

#------ Set Aliases  ------------------------------------
sub system_loadaliases{
	%PerlSvc::AliasReal =();
	%PerlSvc::RealAlias =();
	my ($alias,$real);
	my $RD = gensym();
	open($RD,$PerlSvc::LibDir.ALIASES);
	while(<$RD>){
		if(/^#/){next;}
		chomp;s/\r//;
		($alias,$real)=split(/\s+/,$_);
		$PerlSvc::AliasReal{$alias}=$real;
		$PerlSvc::RealAlias{$real}=$alias;
	}
	close($RD);
	return(1);
}
#------ Get Hostname ------------------------------------
sub system_gethostname{
	my $s = shift(@_);
	my $host;
	$host=gethostbyaddr($s->peeraddr(),AF_INET);
	unless($host){
		$host=$s->peerhost();
	}
	return($host);
}
#------ Get IPADDR ------------------------------------
sub system_gethostaddr{
	my $s = shift(@_);
	my $ip='';
	$ip=inet_ntoa($s->peeraddr());
	return($ip);
}
#------ Check Host --------------------------------------
sub system_checkhost{
	my $l     = shift(@_);
	my $h     = shift(@_);
	my $ipadr = shift(@_);
	my $unchecked=shift(@_);
	my $RD;
	my $con;
	my @check=($h);
	push(@check,$ipadr) if($h ne $ipadr);
	
	if($::Debug){
		print "system_checkhost I am $h and $ipadr\n";
	}
	$RD = gensym();
	open($RD,"$l");
	while(<$RD>){
		if(/^#/){next;}
		chop;s/\r//;
		if(($_ eq '') || (/^\s+$/)){next;}
		$unchecked=0;
		s/\*/\.\+/g;
		if($::Debug){
			print "system_checkhost Checking with $_\n";
		}
		foreach $con (@check){
#			if($con eq $_){
			if($con=~/^$_$/){
				if($::Debug){
					print "system_checkhost Matched with $_\n";
				}
				close($RD);
				return(1);
			}
		}
	}
	close($RD);
	return($unchecked);
}
