#!/usr/bin/perl
my($VERSION)=(qw$Id: l7directord,v 0.2.0 2005/08/31 00:00:01 NTT Comware Exp $)[2];

#########################################################################
# l7directord                                                 August 2005
#
# Linux Director Daemon for L7 - run "perldoc l7directord" for details
# Copyright (C) 2005  NTT COMWARE Corporation.
#
# This program is developed on similar lines of ldirectord. It handles l7vsadm and
# monitoring of real servers. 
#
# Note : The existing code of ldirectord that is not required for l7directord is also 
# maintained in the program but is commented out.
#
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
# 02110-1301, USA.
#
#########################################################################

=head1 NAME

l7directord - Linux Director Daemon for L7

Daemon to monitor remote services and control Linux Virtual Server (L7)


=head1 SYNOPSIS

B<l7directord> [B<-d>] [B<-h>] I<configuration> 
B<start>|B<stop>|B<restart>|B<reload>|B<status>


=head1 DESCRIPTION

B<l7directord> is a daemon to monitor and administer real servers in a
cluster of load balanced virtual servers. B<l7directord> is similar to B<ldirectord> 
in terms of functionality except that it triggers B<l7vsadm>.
B<l7directord> typically is started from command line but can be included
to start from heartbeat. On startup B<l7directord> reads the file 
B</etc/ha.d/conf/>I<configuration>.
After parsing the file, entries for virtual servers are created on the LVS.
Now at regular intervals the specified real servers are monitored and if
they are considered alive, added to a list for each virtual server. If a
real server fails, it is removed from that list. Only one instance of
B<l7directord> can be started for each configuration, but more instances of
B<l7directord> may be started for different configurations. This helps to
group clusters of services.  This can be done by putting an entry inside
B</etc/ha.d/haresources>

I<nodename virtual-ip-address l7directord::configuration>

to start l7directord from heartbeat.


=head1 OPTIONS

I<configuration>:
This is the name for the configuration as specified in the file
B</etc/ha.d/conf/>I<configuration>

B<-d> Don't start as daemon. Useful for debugging.

B<-h> Help. Print user manual of l7directord.

B<start> the daemon for the specified configuration.

B<stop> the daemon for the specified configuration. This is the same as sending
a TERM signal to the running daemon.

B<restart> the daemon for the specified configuration. The same as stopping and starting.

B<reload> the configuration file. This is only useful for modifications
inside a virtual server entry. It will have no effect on adding or
removing a virtual server block. This is the same as sending a HUP signal to
the running daemon.

B<status> of the running daemon for the specified configuration.


=head1 SYNTAX

=head2 Description how to write configuration files

B<virtual = >I<(ip_address|hostname:portnumber|servicename)>

Defines a virtual service by IP-address (or hostname) and port (or
servicename). All real services and flags for a virtual
service must follow this line immediately and be indented.
Firewall-mark settings cannot be set here.

B<checktimeout = >I<n>

Timeout in seconds for connect checks. If the timeout is exceeded then the
real server is declared dead.  Default is 5 seconds. If defined in virtual
server section then the global value is overridden.

B<negotiatetimeout = >I<n>

Timeout in seconds for negotiate checks. Default is defined by the
operating system. If defined in virtual server section then the global
value is overridden.

B<checkinterval = >I<n>

Defines the number of second between server checks. Default is 10 seconds.

B<autoreload = >[B<yes>|B<no>]

Defines if <l7directord> should continuously check the configuration file
for modification. If this is set to 'yes' and the configuration file
changed on disk and its modification time (mtime) is newer than the
previous version, the configuration is automatically reloaded.  Default is
no.

B<callback = ">I</path/to/callback>B<">

If this directive is defined, B<l7directord> automatically calls
the executable I</path/to/callback> after the configuration
file has changed on disk. This is useful to update the configuration
file through B<scp> on the other heartbeated host. The first argument
to the callback is the name of the configuration.

This directive might also be used to restart B<l7directord> automatically
after the configuration file changed on disk. However, if B<autoreload>
is set to yes, the configuration is reloaded anyway.

B<fallback = >I<ip_address|hostname[:portnumber|servicename]> [B<masq>]

the server onto which a web service is redirected if all real
servers are down. Typically this would be 127.0.0.1 with
an emergency page.

This directive may also appear within a virtual server, in which
case it will override the global fallback server, if set.
Only a value of B<masq> can be specified here. The default is I<masq>.


B<logfile = ">I</path/to/logfile>B<">|syslog_facility

An alternative logfile might be specified with this directive. If the logfile
does not have a leading '/', it is assumed to be a syslog(3) facility name.

The default is to log directly to the file I</var/log/l7directord.log>.


B<execute = ">I<configuration>B<">

Use this directive to start an instance of l7directord for
the named I<configuration>.


B<supervised>

If this directive is specified, the daemon does not go into background mode.
All log-messages are redirected to stdout instead of a logfile.
This is useful to run B<l7directord> supervised from daemontools.
See http://untroubled.org/rpms/daemontools/ or http://cr.yp.to/daemontools.html
for details.


B<quiescent = >[B<yes>|B<no>]

If I<yes>, then when real or fallback servers are determined
to be down, they are not actually removed from the kernel's LVS
table. 
If I<no>, then the real or fallback servers will be removed
from the kernel's LVS table. The default is I<yes>.

This directive may also appear within a virtual server, in which
case it will override the global fallback server, if set.


=head2 Section virtual

The following commands must follow a B<virtual> entry and must be indented
with a minimum of 4 spaces or one tab.

B<real => I<ip_address|hostname[-E<gt>ip_address|hostname][:portnumber|servicename>] B<masq> [B<">I<request>B<", ">I<receive>B<">]

Defines a real service by IP-address (or hostname) and port (or
servicename). If the port is omitted then a 0 will be used. 
Optionally a range of IP addresses (or two hostnames) may be
given, in which case each IP address in the range will be treated as a real
server using the given port. The second argument defines the forwarding
method, it must be B<masq> only. The last two arguments are optional. 
They define a request-receive pair to be used to
check if a server is alive. They override the request-receive pair in the
virtual server section. These two strings must be quoted. If the request
string starts with I<http://...> the IP-address and port of the real server is
overridden, otherwise the IP-address and port of the real server is used.

B<module => I<proto-module module-args [opt-module-args]>

Indicates the module parameter of B<l7directord>. Here B<proto-module>
denotes the protocol module name (For example, pfilter). B<module-args> denotes the
arguments for the protocol module (For example, --path-match '*.html*').
The last argument is optional (For example, --reschedule).

=head2 More than one of these entries may be inside a virtual section:

B<checktype = >I<negotiate>|I<connect>|I<N>|I<off>|I<on>

Type of check to perform. Negotiate sends a request and matches a receive
string. Connect only attempts to make a TCP/IP connection, thus the
request and receive strings may be omitted.  If checktype is a number then
negotiate and connect is combined so that after each N connect attempts one
negotiate attempt is performed. This is useful to check often if a service
answers and in much longer intervals a negotiating check is done.  Off
means no checking will take place and no real or fallback servers will be
activated. Default is I<negotiate>.

B<service = ftp>|B<smtp>|B<http>|B<pop>|B<nntp>|B<imap>|B<ldap>|B<https>|B<dns>|B<none>

The type of service to monitor when using checktype=negotiate. None denotes
a service that will not be monitored. If the port specified for the virtual
server is 21, 25, 80, 110, 119, 143, 389 or 443, the default B<ftp>,
B<smtp>, B<http>, B<pop>, B<nntp>, B<imap>, B<ldap>or B<https> respectivly.
Otherwise the default service is B<none>.

B<checkport = >I<n>

Number of port to monitor. Sometimes check port differs from service port.
Default is port specified for the real server.

B<request = ">I<uri to requested object>B<">

This object will be requested each checkinterval seconds on each real
server.  The string must be inside quotes. Note that this string may be
overridden by an optional per real-server based request-string.

For a DNS check this should the name of an A record, or the address
of a PTR record to look up.

B<receive = ">I<regexp to compare>B<">

If the requested result contains this I<regexp to compare>, the real server
is declared alive. The regexp must be inside quotes. Keep in mind that
regexps are not plain strings and that you need to escape the special
characters if they should as literals. Note that this regexp may be
overridden by an optional per real-server based receive regexp.

For a DNS check this should be any one the A record's addresses or
any one of the PTR record's names.

B<virtualhost = ">I<hostname>B<">

Used when using a negotiate check with HTTP or HTTPS. Sets the host header
used in the HTTP request.  In the case of HTTPS this generally needs to
match the common name of the SSL certificate. If not set then the host
header will be derived from the request url for the real server if present.
As a last resort the IP address of the real server will be used.

B<login = ">I<username>B<">

Username to use to login to FTP, POP and IMAP servers. Default is anonymous
for FTP. For POP and IMAP the default is the empty string, in which
case authentication will not be attempted.


B<passwd = ">I<password>B<">

Password to use to login to FTP, POP and IMAP servers. Default is 
l7directord\@<hostname>, where hostname is the environment variable 
HOSTNAME evaluated at run time.


B<scheduler => I<scheduler_name>

Scheduler to be used by LVS for load balancing. 
The available schedulers are only B<lc> and B<rr>. The default is I<rr>.

B<protocol = tcp>

Protocol to be used. B<l7vsadm> supports only B<tcp>. 
Since the virtual is specified as an IP address and port, it would be tcp 
and will default to tcp.


=head1 FILES

B</etc/ha.d/l7directord.cf>

B</var/log/l7directord.log>

B</var/run/l7directord.>I<configuration>B<.pid>

B</etc/services>

=head1 SEE ALSO

L<l7vsadm>, L<heartbeat>


=head1 AUTHORS

NTT Comware

=cut

use strict;
use vars qw(
	    $AUTOCHECK
	    $CHECKINTERVAL
	    $L7DIRECTORD
	    $L7DIRLOG
	    $L7D_TERM_CALLED
	    $NEGOTIATETIMEOUT
	    $RUNPID
	    $CHECKTIMEOUT
	    $QUIESCENT
	    $CALLBACK
	    $CFGNAME
	    $CMD
	    $CONFIG
	    $DEBUG
	    $FALLBACK
	    $SUPERVISED
	    $L7VSADM
	    $checksum
	    $initializing
	    $opt_d
	    $opt_h
	    $pid
	    $stattime
	    %L7D_INSTANCE
	    @OLDVIRTUAL
	    @REAL
	    @VIRTUAL
	    $CRLF	    
);

# Removed $CONNECTIMEOUT variable since it is not used - NTT Comware
# default values
$AUTOCHECK        = "no";
$CHECKINTERVAL    = 10;
$CHECKTIMEOUT     = 5;
$L7DIRECTORD       = "/usr/sbin/l7directord"; # path onto myself
$L7DIRLOG          = "/var/log/l7directord.log";
$L7D_TERM_CALLED   = 0;
$NEGOTIATETIMEOUT = 0;
$RUNPID           = "/var/run/l7directord";
$QUIESCENT        = "yes";

$CRLF = "\x0d\x0a";

use Getopt::Std;
#use English;
#use Time::HiRes qw( gettimeofday tv_interval );
use Socket;
use Sys::Hostname;
#use LWP::Parallel::UserAgent;
use POSIX qw(setsid);
use Sys::Syslog qw(:DEFAULT setlogsock);

# command line options
my @OLD_ARGV = @ARGV;
getopts("dh");

$DEBUG = 3 if (defined $opt_d);

if ($DEBUG>0 and -f "./l7vsadm") {
	$L7VSADM="./l7vsadm";
} else {
	if (-x "/sbin/l7vsadm") {
		$L7VSADM="/sbin/l7vsadm";
	} elsif (-x "/usr/sbin/l7vsadm") {
		$L7VSADM="/usr/sbin/l7vsadm";
	} else {
		die "Can not find l7vsadm";
	}
}

# main code
if ($opt_h) {
	&system_wrapper("/usr/bin/perldoc -U $L7DIRECTORD");
} else {
	# There is a memory leak in perl's socket code when
	# the default IO layer is used. So use "perlio" unless
	# something else has been explicitly set.
	# http://archive.develooper.com/perl5-porters@perl.org/msg85468.html
	unless(defined($ENV{'PERLIO'})) {
		$ENV{'PERLIO'} = "perlio";
		exec_wrapper($0, @OLD_ARGV);
	}

	$initializing = 1;
	ld_init();
	ld_setup();
	ld_start();
	ld_cmd_children("start", %L7D_INSTANCE);
	$initializing = 0;
	ld_main();
}
&ld_rm_file("$RUNPID.$CFGNAME.pid");
&ld_exit(0, "Reached end of \"main\"");


# functions
sub ld_init
{
	# install signal handlers (this covers TERM)
	my $i;
	for $i (keys %SIG) {
		$SIG{"$i"} = \&ld_handler_term;
	}

	# except CHLD, USR1, USR2 and __WARN__
	$SIG{'CHLD'} = "DEFAULT";
	$SIG{'USR1'} = "DEFAULT";
	$SIG{'USR2'} = "DEFAULT";
	$SIG{'__WARN__'} = "DEFAULT";

	# handle PIPE separately as it probably should be ignored
	# This used to call a signal handler, that logged a message
	# However, this typically goes to syslog and if syslog
	# is playing up a loop will occur. 
	$SIG{'PIPE'} = "IGNORE";

	# HUP is actually used
	$SIG{'HUP'} = \&ld_handler_hup;

	# search for the correct configuration file
	if ( !defined $ARGV[0] ) {
	 	init_error("Usage l7directord [-d] [configfile] \{start|stop|restart|reload|status\}\nRun l7directord -h for more information");
	}
	if ( defined $ARGV[0] && defined $ARGV[1] ) {
		$CONFIG = $ARGV[0];
		if ($CONFIG =~ /([^\/]+)$/) {
			$CFGNAME = $1;
		}
		$CMD = $ARGV[1];
	} elsif ( defined $ARGV[0] ) {
		$CONFIG = "l7directord.cf";
		$CFGNAME = "l7directord";
		$CMD = $ARGV[0];
	}
	if ( $CMD ne "start" && $CMD ne "stop" && $CMD ne "status" && $CMD ne "restart" && $CMD ne "reload") {
	 	init_error("Usage l7directord [-d] [configfile] \{start|stop|restart|reload|status\}\nType l7directord -h for more information");
	}
	if ( -f "/etc/ha.d/$CONFIG" ) {
		$CONFIG = "/etc/ha.d/$CONFIG";
	} elsif ( -f "/etc/ha.d/conf/$CONFIG" ) {
		$CONFIG = "/etc/ha.d/conf/$CONFIG";
	} elsif ( ! -f "$CONFIG" ) {
		init_error("Config file $CONFIG not found");
	}
	my $oldpid;
	if (open(FILE, "<$RUNPID.$CFGNAME.pid")) {
		$_ = <FILE>;
		chomp;
		my $tmppid = $_;
		close(FILE);
		# Check to make sure this isn't a stale pid file
		if (open(FILE, "</proc/$tmppid/cmdline")) {
			$_ = <FILE>;
			if (/l7directord/) {
				$oldpid = $tmppid;
			}
			close(FILE);
		}
	}
	if (defined $oldpid) {
		# Kill old daemon
		if ($CMD eq "stop") {
			kill 15, $oldpid;
			ld_exit(0, "Exiting from l7directord stop");
		} elsif ($CMD eq "restart") {
			kill 15, $oldpid;
			while (-f "$RUNPID.$CFGNAME.pid") {
				# wait until old pid file is removed
			}
		} elsif ($CMD eq "reload") {
			kill 1, $oldpid;
			ld_exit(0, "Exiting from l7directord reload");
		} elsif ($CMD eq "status") {
			print STDERR "l7directord for $CONFIG is running with pid: $oldpid\n";
			ld_cmd_children("status", %L7D_INSTANCE);
			ld_exit(0, "Exiting from l7directord status");
		} else {
			init_error("l7directord for $CONFIG is already running with pid: $oldpid");
		}
	} else {
		if ($CMD eq "status") {
			init_error("l7directord is stopped for $CONFIG");
			# Clean up
			ld_exit(0, "Exiting from l7directord status");
		} elsif ($CMD ne "start") {
			init_error("l7directord is stopped for $CONFIG");
		}
	}
	read_config();
	undef @OLDVIRTUAL;

	# Run as daemon
	if ($SUPERVISED || defined $opt_d) {
		&ld_log("Starting Linux Director v$VERSION with pid: $$");
        } else {
		&ld_log("Starting Linux Director v$VERSION as daemon");
		open(FILE, ">$RUNPID.$CFGNAME.pid") || 
			init_error("Can not open $RUNPID.$CFGNAME.pid");
		&ld_daemon();
		print FILE "$$\n";
		close(FILE);
	}
}


sub init_error
{
	my $msg = shift;
	chomp($msg);
	&ld_log("$msg");
	unless (defined $opt_d) {
		print STDERR "$msg\n";
	}
	ld_exit(1, "Initialisation Error");
}


# ld_handler_term
# If we get a sinal then log it and quit
sub ld_handler_term
{
        my ($signal) = (@_);
	print STDERR "l7directord $CFGNAME received signal: $signal\n";
	if ($L7D_TERM_CALLED){
		$SIG{'__DIE__'} = "IGNORE";
		$SIG{"$signal"} = "IGNORE";
		die("Exit Handler Repeatedly Called\n");
	}
	$L7D_TERM_CALLED = 1;

	ld_cmd_children("stop", %L7D_INSTANCE);
	ld_stop();
	&ld_log("Linux Director Daemon terminated on signal: $signal");
	&ld_rm_file("$RUNPID.$CFGNAME.pid");
	&ld_exit(0, "Linux Director Daemon terminated on signal: $signal");
}


sub ld_handler_hup
{
        my ($signal) = (@_);
	&ld_log("Reloading Linux Director Daemon config on signal: $signal");
	&reread_config();
}


sub reread_config
{
	@OLDVIRTUAL = @VIRTUAL;
	my %OLD_INSTANCE = %L7D_INSTANCE;
	eval {
		&read_config();
		my %NEW_INSTANCE = %L7D_INSTANCE;
		&ld_setup();
		&ld_start();
		my $child;
		foreach $child (keys %OLD_INSTANCE) {
			if (exists $NEW_INSTANCE{$child}) {
				delete $OLD_INSTANCE{$child};
				delete $NEW_INSTANCE{$child};
				if (system("$L7DIRECTORD $child reload")) {
					system("$L7DIRECTORD $child start");
				}
			}
		}
		&ld_cmd_children("stop", %OLD_INSTANCE);
		&ld_cmd_children("start", %NEW_INSTANCE);
	};
	if ($@) {
		@VIRTUAL = @OLDVIRTUAL;
		%L7D_INSTANCE = %OLD_INSTANCE;
	}
	undef @OLDVIRTUAL;
}


sub read_config
{
	undef @VIRTUAL;
	undef @REAL;
	undef $CALLBACK;
	undef %L7D_INSTANCE;
	undef $checksum;
	$SUPERVISED = 0;
	$stattime = 0;
	open(CFGFILE, "<$CONFIG") or
		&config_error(0, "can not open file $CONFIG");
	my $line = 0;
	while(<CFGFILE>) {
		$line++;
		outer_loop:
		if ($_ =~ /^virtual\s*=\s*(.*)/) {
			my $vattr = $1;
			my $ip_port = undef;
			# Commented out fwm related program code since it is not used - NTT Comware
			#my $fwm = undef;
			my $virtual_line = $line;
			my $fallback_line;
			my @rsrv_todo;
			if ($vattr =~ /^(\d+\.\d+\.\d+\.\d+):([0-9A-Za-z]+)/) {
				$ip_port = "$1:$2";
			} elsif ($vattr =~ /^([0-9A-Za-z._+-]+):([0-9A-Za-z]+)/) {
				$ip_port = "$1:$2";
			}
			# Commented out fwm related program code since it is not used - NTT Comware
			#} elsif ($vattr =~ /^(\d+)/){
			#	$fwm = $1;			

			# Removed fwm related program code since it is not used - NTT Comware
			#unless($ip_port or $fwm) {
			unless($ip_port) {
				&config_error($line, 
					"invalid address for virtual server");
			}

			my (%vsrv, @rsrv);
			if ($ip_port) {
				$vsrv{checktype} = "negotiate";
			        $vsrv{protocol} = "tcp";
			        # Commented out code for udp, now even port 53 would be tcp
				#if ($ip_port =~ /:53$/) {
				#	$vsrv{protocol} = "udp";
				#}
			}
			# Removed fwm related program code since it is not used - NTT Comware
			#} else {
			#        $vsrv{fwm} = $fwm;
			#	$vsrv{checktype} = "negotiate";
			#        $vsrv{protocol} = "fwm";
			#	$vsrv{service} = "none";
			#	$vsrv{port} = "0";
			#}
			$vsrv{real} = \@rsrv;
			# Changed default scheduler to rr instead of wrr - NTT Comware
			#$vsrv{scheduler} = "wrr";
			$vsrv{scheduler} = "rr";
			$vsrv{request} = "/";
			$vsrv{receive} = "";
			$vsrv{login} = "";
			$vsrv{passwd} = "l7directord\@$ENV{HOSTNAME}";
			$vsrv{checktimeout} = 0;
			$vsrv{negotiatetimeout} = 0;
			$vsrv{num_connects} = 0;
			push(@VIRTUAL, \%vsrv);
			while(<CFGFILE>) {
				$line++;
				if(m/^\s*#/) {
					next;
				}
				s/#.*//;
				s/\t/    /g;
				unless (/^ {4,}(.+)/) {
					last;
				}
				my $rcmd = $1;
				if ($rcmd =~ /^real\s*=\s*(.*)/) {
					push @rsrv_todo, [$1, $line];
				} elsif ($rcmd =~ /^request\s*=\s*\"(.*)\"/) {
					$1 =~ /(.+)/ or &config_error($line, "no request string specified");
					$vsrv{request} = $1;
					unless($vsrv{request}=~/^\//){
						$vsrv{request} = "/" . $vsrv{request};
					}

				} elsif ($rcmd =~ /^receive\s*=\s*\"(.*)\"/) {
					$1 =~ /(.+)/ or &config_error($line, "invalid receive string");
					$vsrv{receive} = $1;
				} elsif ($rcmd =~ /^checktype\s*=\s*(.*)/){
                                        lc($1);
					if ($1 =~ /(\d+)/ && $1>=0) {
						$vsrv{num_connects} = $1;
						$vsrv{checktype} = "combined";
					} elsif ( $1 =~ /(\w+)/ && ($1 eq "connect" || $1 eq "negotiate" || $1 eq "off" || $1 eq "on") ) {
						$vsrv{checktype} = $1;
					} else {
						&config_error($line, "checktype must be connect, negotiate, off, on or a positive number");
					}
				} elsif ($rcmd =~ /^checktimeout\s*=\s*(.*)/){
                                        $1 =~ /(\d+)/ && $1 or &config_error($line, "invalid check timeout");
                                        $vsrv{checktimeout} = $1;
				# Commented out connectimeout since it is not used - NTT Comware
				#} elsif ($rcmd =~ /^connecttimeout\s*=\s*(.*)/){
                                #        $1 =~ /(\d+)/ && $1 or &config_error($line, "invalid check timeout");
                                #        $vsrv{connecttimeout} = $1;
				} elsif ($rcmd =~ /^negotiatetimeout\s*=\s*(.*)/){
                                        $1 =~ /(\d+)/ && $1 or &config_error($line, "invalid neogtiate timeout");
                                        $vsrv{negotiatetimeout} = $1;
				} elsif ($rcmd =~ /^checkport\s*=\s*(.*)/){
					$1 =~ /(\d+)/ or &config_error($line, "invalid port");
					( $1 > 0 && $1 < 65536 ) or &config_error($line, "checkport must be in range 1..65536");
					$vsrv{checkport} = $1;
				} elsif ($rcmd =~ /^login\s*=\s*\"(.*)\"/) {
					$1 =~ /(.+)/ or &config_error($line, "invalid login string");
					$vsrv{login} = $1;
				} elsif ($rcmd =~ /^passwd\s*=\s*\"(.*)\"/) {
					$1 =~ /(.+)/ or &config_error($line, "invalid password");
					$vsrv{passwd} = $1;
				# Removed load related checks since it is not used - NTT Comware
				#} elsif ($rcmd =~ /^load\s*=\s*\"(.*)\"/) {
				#	$1 =~ /(\w+)/ or &config_error($line, "invalid string for load testing");
				#	$vsrv{load} = $1;
				#	lc($1);
				} elsif ($rcmd =~ /^scheduler\s*=\s*(.*)/) {
					# L4 ldirectord just checks whether the scheduler is any text string.
					# But for l7vsadm, modified the scheduler check such that only lc or rr is allowed
					# since l7vsadm supports only lc or rr scheduling - NTT Comware					
					#$1 =~ /([a-z]+)/ 
					#    or &config_error($line, "invalid scheduler, should be only lowercase letters (a-z)");
					($1 eq "lc" || $1 eq "rr")
                                                or &config_error($line, "invalid scheduler, should be only lc or rr");				
					$vsrv{scheduler} = $1;
				# Removed persistent and netmask related checks and variables since it is not used - NTT Comware
				#} elsif ($rcmd =~ /^persistent\s*=\s*(.*)/) {
				#	$1 =~ /(\d+)/ or &config_error($line, "invalid persistent timeout");
				#	$vsrv{persistent} = $1;
				#} elsif ($rcmd =~ /^netmask\s*=\s*(.*)/) {
				#	$1 =~ /(\d+\.\d+\.\d+\.\d+)/ or &config_error($line, "invalid netmask");
				#	$vsrv{netmask} = $1;
				} elsif ($rcmd =~ /^protocol\s*=\s*(.*)/) {
					lc($1);
					# Removed fwm/udp related program code since it is not used - NTT Comware
					#if ( $1 =~ /(\w+)/ ) {
						#if ( $vsrv{protocol} eq "fwm" ) {
						#	if ($1 eq "fwm" ) {
						#		; #Do nothing, it is already set
						#	} else {
						#		&config_error($line, "protocol must be fwm if the virtual service is a fwmark (a number)");
						#	}
						#} else {    # tcp or udp
						#	if ($1 eq "tcp" || $1 eq "udp") {
						#		$vsrv{protocol} = $1;
						#	} else {
						#		&config_error($line, "protocol must be tcp or udp if the virtual service is an address and port");
						#	}
						#}
					#} else {
					#	&config_error($line, "invalid protocol");
					#}		
					if ( $1 =~ /(\w+)/ ) {
						if ($1 eq "tcp") {
							$vsrv{protocol} = $1;
						} else {
							&config_error($line, "invalid protocol. protocol must be tcp");
						}
					}
				} elsif ($rcmd =~ /^service\s*=\s*(.*)/) {
					lc($1);
					$1 =~ /(\w+)/ && ($1 eq "http" || $1 eq "https" || $1 eq "ldap"
					    || $1 eq "ftp" || $1 eq "none" || $1 eq "smtp" || $1 eq "pop" || $1 eq "imap" || $1 eq "nntp" || $1 eq "dns")
					    or &config_error($line, "service must be http, https, ftp, smtp, pop, imap, ldap, nntp, dns or none");
					$vsrv{service} = $1;
					if($vsrv{service} eq "ftp" and 
							$vsrv{login} eq "") {
						$vsrv{login} = "anonymous";
					}
				} elsif ($rcmd =~ /^virtualhost\s*=\s*(.*)/) {
					$1 =~ /\"?([^"]*)\"?/ or
					&config_error($line, "invalid virtualhost");
					$vsrv{virtualhost} = $1;
				} elsif ($rcmd =~ /^fallback\s*=\s*(.*)/) {    # Allow specification of a virtual-specific fallback host
					$fallback_line=$line;
					$vsrv{fallback}=parse_fallback($line, $1);
                                } elsif ($rcmd =~ /^quiescent\s*=\s*(.*)/) {
                                        ($1 eq "yes" || $1 eq "no")
                                                or &config_error($line, "quiescent must be 'yes' or 'no'");
					$vsrv{quiescent} = $1;
				# Added the module part of the code for l7vsadm - NTT Comware
				# This reads if the line starts with string as module
				} elsif ($rcmd =~ /^module\s*=\s*(.*)/) {
					$1 =~ /(.+)/ or &config_error($line, "No module is specified");
					$vsrv{module} = $1;
					# Translate the " character into ' character. This will be useful for triggering l7vsadm
					# Even if the user inputs " character it will be taken as the ' character
					$vsrv{module}=~ tr/"/'/d;

					# Added code for getting the key values of the virtual service - NTT Comware
					# module key is a vital part in uniquely identifying the virtual service.
					my $module=$vsrv{module};
					my $module_key='';
					if ( ($module=~/^(pfilter).*?( --path-match\s+[^\s]+)/)  || 
					($module=~/^(url).*?( --pattern-match\s+[^\s]+)/) ) {
						# For pfilter, $module_key would be returned as "pfilter --path-match xxxx"
						# For url, $module_key would be returned as "url --pattern-match xxxx"
						$module_key=$1.$2;
					} else {
						&config_error($line, "module argument should be of pfilter or url types");
					}
					$vsrv{module_key}=$module_key;
				
				} else {
					&config_error($line, "Unknown command $_");
				}
			}
			# As the protocol needs to be known to call
			# getservbyname() all resolution must be 
			# delayed until the protocol is finalised.
			# That is after the entire configuration
			# for a virtual service has been parsed.

			&_ld_read_config_fallback_resolve($fallback_line, 
				$vsrv{protocol}, $vsrv{fallback});
			&_ld_read_config_virtual_resolve($virtual_line, \%vsrv,
				$ip_port);
			&_ld_read_config_real_resolve(\%vsrv, \@rsrv_todo);

			#Arggh a goto :(
			goto outer_loop;
		}
		next if ($_ =~ /^\s*$/ || $_ =~ /^\s*#/);
		if ($_ =~ /^checktimeout\s*=\s*(.*)/) {
			($1 =~ /(\d+)/ && $1 && $1>0) or &config_error($line, 
					"invalid check timeout value");
			$CHECKTIMEOUT = $1;
		# Commented out connecttimeout related checks since it is not used - NTT Comware
		#} elsif ($_ =~ /^connecttimeout\s*=\s*(.*)/) {
		#	($1 =~ /(\d+)/ && $1 && $1>0) or &config_error($line, 
		#			"invalid timeout value");
		#	$CONNECTTIMEOUT = $1;
		} elsif ($_ =~ /^negotiatetimeout\s*=\s*(.*)/) {
			($1 =~ /(\d+)/ && $1 && $1>0) or &config_error($line, 
					"invalid negotiate timeout value");
			$NEGOTIATETIMEOUT = $1;
		} elsif ($_ =~ /^checkinterval\s*=\s*(.*)/) {
			$1 =~ /(\d+)/ && $1 or &config_error($line, 
					"invalid checkinterval value");
			$CHECKINTERVAL = $1;
		} elsif ($_ =~ /^fallback\s*=\s*(.*)/) {
                        my $tcp = &ld_gethostservbyname($1, "tcp");
                        # Commented out udp related code since it is not used - NTT Comware
			#my $udp = &ld_gethostservbyname($1, "udp");
                        my $tcp_fb;
                        #my $udp_fb;
			#if(!defined($tcp) and !defined($udp)){
			#   &config_error($line, 
			#   	"invalid address for fallback server");
			#}
			if (!defined($tcp)) {
			    &config_error($line, 
			    	"invalid address for fallback server");
			} else {
				$tcp_fb=&parse_fallback($line, $tcp);
			}
			# Commented out udp related code since it is not used
			# tcp related code is added in the above ELSE loop - NTT Comware
                        #if(defined($tcp)) {
			#        $tcp_fb=&parse_fallback($line, $tcp);
                        #}
                        #if(defined($udp)) {
			#        $udp_fb=&parse_fallback($line, $udp);
                        #}
			#$FALLBACK = { "tcp" => $tcp_fb, "udp" => $udp_fb };
			$FALLBACK = { "tcp" => $tcp_fb };
		} elsif ($_ =~ /^autoreload\s*=\s*(.*)/) {
#			print "string=$1\n"; 
			($1 eq "yes" || $1 eq "no")
			    or &config_error($line, 
			    		"autoreload must be 'yes' or 'no'");
			$AUTOCHECK = $1;
		} elsif ($_ =~ /^callback\s*=\s*\"(.*)\"/) {
			$CALLBACK = $1;
		} elsif ($_ =~ /^logfile\s*=\s*\"(.*)\"/) {
			my $tmpL7DIRLOG = $L7DIRLOG;
			$L7DIRLOG = $1;
			if (&ld_openlog()) {
				$L7DIRLOG = $tmpL7DIRLOG;
				&config_error($line, 
						"unable to open logfile: $1");
			}
		} elsif ($_ =~ /^execute\s*=\s*(.*)/) {
			$L7D_INSTANCE{$1} = 1;
		} elsif ($_ =~ /^supervised/) {
			$SUPERVISED = 1;
		} elsif ($_ =~ /^quiescent\s*=\s*(.*)/) {
			($1 eq "yes" || $1 eq "no")
			    or &config_error($line, 
			    		"quiescent must be 'yes' or 'no'");
			$QUIESCENT = $1;
		} else {
		# Removed timeout related checks since timeout directive is long deprecated and it is not used - NTT Comware
			#if ($_ =~ /^timeout\s*=\s*(.*)/) {
			#	&config_error($line, 
			#			"timeout directive " .
			#			"deprciated in favour of " .
			#			"checktimeout, " .
			#			"negotiatetimeout or " .
			#			"connecttimeout");
			#}
			&config_error($line, "Unknown command $_");
		}
	}
	close(CFGFILE);
	return(0);
}


# _ld_read_config_virtual_resolve
# Note: Should not need to be called direclty, but won't do any damage if
#       you do.
# Resolve the server (ip address) and port for a virtual service
# pre: line: Line of configuration file fallback server was read from
#            Used for debugging messages
#      vsrv: Virtual Service to resolve server and port of
#      ip_port: server and port in the form
#               ip_address|hostname:port|service
# post: Take ip_port, resolve it as per ld_gethostservbyname
#       and set $vsrv->{server} and $vsrv->{port} accordingly.
#       If $vsrv->{service} is not set, then set it to "http",
#       "https", "ftp", "smtp", "pop", "imap", "ldap", "nntp" or "none" 
#       if $vsrv->{port} is 80, 443, 21, 25, 110, 143, 389 or 
#       any other value, respectivley
# return: none
#        Debugging message will be reported and programme will exit
#        on error.

sub _ld_read_config_virtual_resolve
{
	my($line, $vsrv, $ip_port)=(@_);

	if($ip_port){
		$ip_port=&ld_gethostservbyname($ip_port, $vsrv->{protocol});
		if($ip_port){
			($vsrv->{server}, $vsrv->{port}) = split /:/, $ip_port;
		}
		else {
			&config_error($line, 
				"invalid address for virtual service");
		}

		if(!defined($vsrv->{service})){
			if ($vsrv->{port} eq "80") {
				$vsrv->{service} = "http";
			} 
			elsif ($vsrv->{port} eq "443") {
				$vsrv->{service} = "https";
			} 
			elsif ($vsrv->{port} eq "21") {
				$vsrv->{service} = "ftp";
			} 
			elsif ($vsrv->{port} eq "25") {
				$vsrv->{service} = "smtp";
			} 
			elsif ($vsrv->{port} eq "110") {
				$vsrv->{service} = "pop";
			} 
			elsif ($vsrv->{port} eq "119") {
				$vsrv->{service} = "nntp";
			} 
			elsif ($vsrv->{port} eq "143") {
				$vsrv->{service} = "imap";
			} 
			elsif ($vsrv->{port} eq "389") {
				$vsrv->{service} = "ldap";
			}
			elsif ($vsrv->{port} eq "53") {
				$vsrv->{service} = "dns";
			} 
			else {
				$vsrv->{service} = "none";
			}
		}
	}
}


# _ld_read_config_fallback_resolve
# Note: Should not need to be called direclty, but won't do any damage if
#       you do.
# Resolve the fallback server for a virtual service
# pre: line: Line of configuration file fallback server was read from
#            Used for debugging messages
#      vsrv: Virtual Service to resolve fallback server of
# post: Take $vsrv->{fallback}, resolve it as per ld_gethostservbyname
#       and set $vsrv->{fallback} to the result
# reurn: none
#        Debugging message will be reported and programme will exit
#        on error.

sub _ld_read_config_fallback_resolve
{
	my($line, $protocol, $fallback)=(@_);

        my $ip_port;

        unless($fallback) {
                return;
        }

	$fallback->{server}=&ld_gethostservbyname(
                $fallback->{server}, $protocol) 
	        or &config_error($line, 
		        "invalid address for fallback server");
}


# _ld_read_config_real_resolve
# Note: Should not need to be called direclty, but won't do any damage if
#       you do.
# Run thourgh the list of real servers read in the configuration file for a
# virtual server and parse these entries
# pre: vsrv: Virtual Service to parse real servers for
#      rsrv_todo: List of real servers read from config but not parsed.
#                 List is a list of list reference. The firest element in
#                 each list reference is the line read from the
#                 configuration after "real=". The second element is the
#                 line number, used for error reporting
# post: Run through rsrv_todo and parse real servers
# reurn: none
#        Debugging message will be reported and programme will exit
#        on error.

sub _ld_read_config_real_resolve
{
	my ($vsrv, $rsrv_todo)=(@_);

	my $i;
	my $str;
	my $line;
	my $ip1;
	my $ip2;
	my $port;
	my $resolved_ip1;
	my $resolved_ip2;
	my $resolved_port;
	my $flags;

	for $i (@$rsrv_todo) {
		($str, $line)=@$i;
		$str =~	 /(\d+\.\d+\.\d+\.\d+|[A-Za-z0-9.-]+)(->(\d+\.\d+\.\d+\.\d+|[A-Za-z0-9.-]+))?(:(\d+|[A-Za-z0-9-]+))?\s+(.*)/
			or &config_error($line, 
				"invalid address for real server" .
                                " (wrong format)");
		$ip1=$1;
		$ip2=$3;
                if(defined($5)){
		   $port=$5;
                }
                else {
                   $port="0";
                }
		$flags=$6;
		$resolved_ip1=&ld_gethostbyname($ip1);
                unless( defined($resolved_ip1) ) {
			&config_error($line, 
                                "invalid address ($ip1) for real server" .
                                " (could not resolve host)");
                }
		if( defined($port) ){
			$resolved_port=&ld_getservbyname($port);
                        unless( defined($resolved_port) ){
				&config_error($line, 
                                        "invalid port ($port) for real server" .
                                        " (could not resolve port)");
                        }
		}
		if ( defined ($ip2) ) {
			$resolved_ip2=&ld_gethostbyname($ip2);
                        unless( defined ($resolved_ip2) ) {
				&config_error($line, 
                                        "invalid address ($ip2) for " .
					"real server" .
                                        " (could not resolve end host)");
                        }
			&add_real_server_range($line, $vsrv, $resolved_ip1, 
				$resolved_ip2, $resolved_port, $flags);
		} else {
			&add_real_server($line, $vsrv, $resolved_ip1, 
				$resolved_port, $flags);
		}
	}
}


# add_real_server_range
# Add a real server for each IP address in a range
# pre: line: line number real server was read from
#            Used for debugging information
#      vsrv: virtual server to add real server to
#      first: First IP address in range
#      last: First IP address in range
#      port: Port of real servers
#      flags: Flags for real servers. Should be of the form
#             masq [">I<request>", "<receive>"]
# post: real servers are added to virtual server
# return: none
#         Debugging message will be reported and programme will exit
#         on error.

sub add_real_server_range
{
	my ($line, $vsrv, $first, $last, $port, $flags) = (@_);

        my (@tmp, $first_i, $last_i, $i, $rsrv);

	if ( ($first_i=&ip_to_int($first)) <0 ) {
		&config_error($line, "Invalid IP address: $first");
	}
	if ( ($last_i=&ip_to_int($last)) <0 ) {
		&config_error($line, "Invalid IP address: $last");
	}

	if ($first_i>$last_i) {
		&config_error($line, 
			"Invalid Range: $first-$last: First value must be " .
			"less than or equal to the second value");
	}

	# A for loop didn't seem to want to work
	$i=$first_i;
	while ( $i le $last_i ) {
		&add_real_server($line, $vsrv, &int_to_ip($i), $port, $flags);
		$i++;
	}
}


# add_real_server
# Add a real server to a virtual
# pre: line: line number real server was read from
#            Used for debugging information
#      vsrv: virtual server to add real server to
#      ip: IP address of real server
#      port: Port of real server
#      flags: Flags for real server. Should be of the form
#             masq [">I<request>", "<receive>"]
# post: real server is added to virtual server
# return: none
#         Debugging message will be reported and programme will exit
#         on error.

sub add_real_server
{
	my ($line, $vsrv, $ip, $port, $flags) = (@_);

	my $ref;
	my $realsrv=0;
	my $new_rsrv;
	my $rsrv;

	$new_rsrv = {"server"=>$ip, "port"=>$port};

	# Removed gate/ipip part of the code since l7vsadm supports only masq - NTT Comware
	#$flags =~ /(\w+)(.*)/ && ($1 eq "gate" || $1 eq "masq" || $1 eq "ipip")
	#	    or &config_error($line, 
	#    	"forward method must be gate, masq or ipip");
	$flags =~ /(\w+)(.*)/ && ($1 eq "masq")
	    or &config_error($line, "forward method must be masq");

	$new_rsrv->{"forward"} =$1;
	$flags = $2;

	$rsrv=$vsrv->{"real"};

	# l7vsadm does not support weight parameter.
	# This part of the code related to weight is modified to thrown error - NTT Comware
	#if(defined($flags) and $flags =~ /\s+(\d+)(.*)/) {
	#	$new_rsrv->{"weight"} = $1;
	#	$flags = $2;
	#}
	if(defined($flags) and $flags =~ /\s+(\d+)(.*)/) {
		&config_error($line, "Weight cannot be set for l7vsadm");
	}	

	if(defined($flags) and $flags =~ /\s+\"(.*)\"[, ]\s*\"(.*)\"(.*)/) {
		$new_rsrv->{"request"} = $1;
		$new_rsrv->{"receive"} = $2;
		$flags = $3;
	}

	if (defined($flags) and $flags =~/\S/) {
		&config_error($line, "Invalid real server line, around "
			. "\"$flags\"");
	}

	push(@$rsrv, $new_rsrv);

        my $real    = get_real_id_str($new_rsrv, $vsrv);
	my $virtual = get_virtual_id_str($vsrv);
	for my $r (@REAL){
		if($r->{"real"} eq $real){
			my $ref=$r->{"virtual"};
			push(@$ref, $virtual);
			$realsrv=1;
			last;
		}
	}
	if($realsrv==0){
		push(@REAL, { "real"=>$real, "virtual"=>[ $virtual ] });
	}
}


# parse_fallback
# Parse a fallback server
# pre: line: line number real server was read from
#      fallback: line read from configuration file
#                Should be of the form
#                ip_address|hostname[:port|:service_name] masq
# post: fallback is parsed
# return: Reference to hash of the form
#         { server => blah, forward => blah }
#         Debugging message will be reported and programme will exit
#         on error.

sub parse_fallback
{
	my ($line, $fallback) = (@_);

	my $ip_port;
	my $fwd;

        $fallback =~ /^\s*(\S+)(\s+(\S+))?\s*/ or
                  &config_error($line, "invalid fallback server: $fallback");

        $ip_port=$1;
        $fwd=$3;

	# Removed gate/ipip part of the code since l7vsadm supports only masq - NTT Comware
	# Also default for forwarding mechanism is made as masq
        if($fwd) {
                #($fwd eq "gate" || $fwd eq "masq" || $fwd eq "ipip")
	        #or &config_error($line, 
	    	#        "forward method must be gate, masq or ipip");        
                ($fwd eq "masq")
	        or &config_error($line, "forward method must be masq");
        }
        else {
          #$fwd="gate"
          $fwd="masq"
        }

	return({"server"=>$ip_port, "forward"=>$fwd});
}


sub config_error
{
	my ($line, $msg) = @_;

        chomp($msg);
        $msg .= "\n";

	if (defined $opt_d || $initializing==1) {
		if ($line>0) {
			print STDERR "Error [$pid] reading file $CONFIG at line $line: $msg";
		} else {
			print STDERR "Error: $msg\n";
		}
	} else {
		if ($line>0) {
			&ld_log("Error [$pid] reading file $CONFIG at line $line: $msg");
		} else {
			 &ld_log("Error: $msg\n");
		}
	}
	if ($initializing) {
		&ld_rm_file("$RUNPID.$CFGNAME.pid");
		&ld_exit(2, "config_error: Configuration Error");
	} else {
		die;
	}
}


sub ld_setup
{
	for my $v (@VIRTUAL) {
		if ($$v{protocol} eq "tcp") {
			$$v{proto} = "-t";
		}
		# Removed out udp and fwm related code since it is not used - NTT Comware
		#} elsif ($$v{protocol} eq "udp") {
		#	$$v{proto} = "-u";
		#} elsif ($$v{protocol} eq "fwm") {
		#	$$v{proto} = "-f";
		#}
		$$v{flags} = "$$v{proto} " .  &get_virtual($v) . " ";
		# Added the module part as the flag for l7vsadm - NTT Comware
		$$v{flags} .= "-m $$v{module} ";
		$$v{flags} .= "-s $$v{scheduler} " if defined ($$v{scheduler});
		# Removed persistent and netmask related flag setting since it is not used - NTT Comware
		#if (defined $$v{persistent}) {
		#	$$v{flags} .= "-p $$v{persistent} ";
		#	$$v{flags} .= "-M $$v{netmask} " if defined ($$v{netmask});
		#}
		
		# Added code for getting module related parameters for l7vsadm from the module directive
		# Currently v{module_param} will just hold the module name (proto-module), for example, pfilter.
		# When l7vsadm would give even module-arguments in its output, this has to be modified
		# At that time, it can be the v{module_key} minus the module name part - NTT Comware
		$$v{module_param}=(split / /, $$v{module})[0];
		
		my $real = $$v{real};
		for my $r (@$real) {
			# Keeping the $$r{forw} as it is even though it is not used
			# If this is removed then subsequently the calling parameters for sub-routines _restore_service 
			# and _remove_service have to be modified. By keeping this variable as it is, they can be kept 
			# the same for calling the above two sub-routines - NTT Comware
                        $$r{forw} = get_forward_flag($$r{forward});
                        
                        # Modified weight part of the code such that it is set always to 1
                        # Weight is not used in l7vsadm though
			# If this is removed then subsequently the calling parameters for sub-routine _restore_service 
			# has to be modified. By keeping this variable as it is,  they can be kept 
			# the same for calling the above two sub-routines - NTT Comware
                        #if (defined $$r{weight}) {
			#	 $$r{wght} = "$$r{weight}";
			#} else {
			#	 $$r{wght} = "1";
			#}
			$$r{wght} = "1";
			
        		if (defined $$r{request} && defined $$r{receive}) {
				my $uri = $$r{request};
				$uri =~ s/^\///g;
				if ($$r{request} =~ /$$v{service}:\/\//) {
					$$r{url} = "$uri";
				} else {
					my $port=(defined $$v{checkport}?$$v{checkport}:$$r{port});
					$$r{url} = "$$v{service}:\/\/$$r{server}:$port\/$uri";
				}
			} else {
				my $uri = $$v{request};
				$uri =~ s/^\///g;
				my $port=(defined $$v{checkport}?$$v{checkport}:$$r{port});
				$$r{url} = "$$v{service}:\/\/$$r{server}:$port\/$uri";

                		$$r{request} = $$v{request} unless defined $$r{request};
                		$$r{receive} = $$v{receive};
			}
			if ($$v{checktype} eq "combined") {
				$$r{num_connects} = 999999;
			} else {
				$$r{num_connects} = -1;
			}
		}
		$$v{checktimeout} = $CHECKTIMEOUT if ($$v{checktimeout}<=0);
		# Removed connecttimeout related variables since it is not used (including $CONNECTIMEOUT) - NTT Comware
		#$$v{connecttimeout} = $CONNECTTIMEOUT if ($$v{connecttimeout}<=0);
		#$$v{connecttimeout} = $$v{checktimeout} if ($$v{connecttimeout}<=0);
		$$v{negotiatetimeout} = $NEGOTIATETIMEOUT if ($$v{negotiatetimeout}<=0);
		$$v{negotiatetimeout} = $$v{checktimeout} if ($$v{negotiatetimeout}<=0);
	}
}

# Removed persistent and netmask related hash entries from the structure of l7vsadm since it is not used - NTT Comware
# ld_read_l7vsadm
# Parses the output of "l7vsadm -L -n" and puts into a structure of
# the following from:
# 
# {
#   (vip_address:vport) protocol module_name => {
#     "scheduler" => scheduler,
#     "real" => {
#       rip_address:rport => {
#         "forward" => forwarding_mechanism,
#         "weight"  => weight
#       },
#       ...
#     }
#   },
#   ...
# }
# 
# where: 
#   vip_address: IP address of virtual service
#   vport: Port of virtual service
#   module_name: Depicts the name of the module (For example, pfilter)
#   scheduler: Scheduler for virtual service
#
#   rip_address: IP address of real server
#   rport: Port of real server
#   forwarding_mechanism: Forwarding mechanism for real server. This would be only masq.
#   weight: Weight of real server
#
# pre: none
# post: l7vsadm -L -n is parsed
# result: reference to structure detailed above.

sub ld_read_l7vsadm
{
	my %oldsrv;
	my $real_service;
	my $fwd;

	# read status of current l7vsadm -L -n
	unless(open(L7VS, "$L7VSADM -L -n |")){
          &ld_exit(-1, "Could not run $L7VSADM -L -n");
        }
	$_ = <L7VS>; $_ = <L7VS>; $_ = <L7VS>;

	while (<L7VS>) {
	# Commented out persistent and netmask related hash entries since it is not used.
	# Added l7vsadm module directive that is also present in the output.
	# Included the module as part of the $real_service in the hash - NTT Comware
	#	if ($_ =~ /(\w+)\s+(\d+\.\d+\.\d+\.\d+\:\d+|\d+)\s+(\w+)\s+persistent\s+(\d+)\s+mask\s+(.*)/) {
	#		$real_service = "$2 ".lc($1);
	#		$oldsrv{"$real_service"} = {"real"=>{}, "scheduler"=>$3, "persistent"=>$4, "netmask"=>$5};
	#	} elsif ($_ =~ /(\w+)\s+(\d+\.\d+\.\d+\.\d+\:\d+|\d+)\s+(\w+)\s+persistent\s+(\d+)/) {
	#		$real_service = "$2 ".lc($1);
	#		$oldsrv{"$real_service"} = {"real"=>{}, "scheduler"=>$3, "persistent"=>$4};
	#	} elsif ($_ =~ /(\w+)\s+(\d+\.\d+\.\d+\.\d+\:\d+|\d+)\s+(\w+)/)
		if ($_ =~ /(\w+)\s+(\d+\.\d+\.\d+\.\d+\:\d+|\d+)\s+(\w+)\s+(\w+)/) {
			# Added the module flag here. $3 indicates the module flag - NTT Comware
			$real_service = "$2 ".lc($1)." $3";
			$oldsrv{"$real_service"} = {"real"=>{}, "scheduler"=>$4};
		} else {
			next;
		}
		while(<L7VS>) {
			last unless $_ =~ / ->\s+(\d+\.\d+\.\d+\.\d+\:\d+)\s+(\w+)\s+(\d+)/;
			# Removed gate/ipip part of the code since l7vsadm supports only masq - NTT Comware
			#if ($2 eq "Route") {
			#	$fwd = "gate";
			#} elsif ($2 eq "Tunnel") {
			#	$fwd = "ipip";
			#} elsif ($2 eq "Masq") {
			#	$fwd = "masq";
			#}
			if ($2 eq "Masq") {
				$fwd = "masq";
			}
			# weight parameter is read, though it is not used (l7vsadm does not support weight) - NTT Comware
			$oldsrv{"$real_service"}->{"real"}->{"$1"} = {"forward"=>$fwd, "weight"=>$3};
		}
		redo;
	}
	close(L7VS);

        return(\%oldsrv);
}

sub ld_start
{
	my $oldsrv;
	# Commented out the variable since it is defined later inside the loop - NTT Comware
	#my $real_service;
	my $nv;
	my $nr;
	my $server_down = {};
	
	# read status of current l7vsadm -L -n
        $oldsrv=&ld_read_l7vsadm();

	# make sure virtual servers are up to date
	foreach $nv (@VIRTUAL) {
		my $real_service = &get_virtual($nv) . " "  . $nv->{protocol} . " $nv->{module_param}";
		my $virtual_exist = 0;

		if (exists($oldsrv->{"$real_service"})) {
			# service exists, delete and create it
			# Since l7vsadm does not give the [module-args] also along with the output
			# Just try to EDIT the existing virtual service. system_wrapper_no_log returns the result
			# Catch the success result and then, delete and create new virtual service
			# When l7vsadm would give even [module-args] in its output, this has to be modified - NTT Comware
			my $result = &system_wrapper_no_log("$L7VSADM -E $$nv{flags}");
			if ($result == 0) {
				# Carry out delete of virtual server and related real server - NTT Comware
				# l7vsadm -D option deletes both the attached real/fallback servers and virtual server
				&system_wrapper("$L7VSADM -D $$nv{proto} " .  &get_virtual($nv) . " -m $$nv{module_key}");
				$virtual_exist = 1;
			}
		}
		
		# added the below logic to distinguish the message for existing virtual service and newly
		# added virtual service - NTT Comware
		&system_wrapper("$L7VSADM -A $$nv{flags}");
		if ($virtual_exist == 1) {
			&ld_log("Changed virtual server: " . &get_virtual($nv) . " $nv->{module_key}");
		} else {
			&ld_log("Added virtual server: " . &get_virtual($nv) . " $nv->{module}");
		}

		# Commented this part of the code and changed the logic as below - NTT Comware
		# Since the real servers would have to be created afresh it is just
		# enough to just ADD them - NTT Comware
		#foreach $nv (@VIRTUAL) {
		#	my $nreal = $nv->{real};
		#	my $ov = $oldsrv->{&get_virtual($nv) . " " . $nv->{protocol}};
		#	my $or = $ov->{real};
		#	my $fallback = fallback_find($nv);
		#
		#	if (defined($fallback)) {
		#		delete($or->{$fallback->{server}});
		#	}
		#
		#	for $nr (@$nreal) {
		#		my $real_str = "$nr->{server}:$nr->{port}";
		#		if (! defined($or->{$real_str}) or
		#				$or->{$real_str}->{weight} == 0) {
		#			$server_down->{$real_str} = [$nv, $nr];
		#			#service_set($nv, $nr, "down", "force");
		#		}
		#		else {
		#			if (defined $server_down->{$real_str}) {
		#				delete($server_down->{$real_str});
		#			}
		#			service_set($nv, $nr, "up", "force");
		#		}
		#		delete($or->{$real_str});
		#}
		
		# make sure real servers are up to date
		my $nreal = $nv->{real};
		for $nr (@$nreal) {
			my $real_str = "$nr->{server}:$nr->{port}";
			$server_down->{$real_str} = [$nv, $nr];
		}
		
		# Commented out since now real servers do not need to be deleted.
		# All of the real servers would anyway have been deleted when
		# l7vsadm -D is executed - NTT Comware
		#for my $k (keys %$or) {
		#	&system_wrapper("$IPVSADM -d " . $nv->{proto} .
		#			&get_virtual($nv) . " -r $k");
		#	&ld_log("Removed real server: $k (" . 
		#			#scalar(%{$nv->{real_status}}) .
		#			" x " .  &get_virtual($nv) . ")\n");
		#	delete($$or{$k});
		#}
		
		#delete($oldsrv->{&get_virtual($nv) . " " . $nv->{protocol}});
		
		# sets fallback server for the virtual service
		&fallback_on($nv);
	}
	
	# make sure real servers are up to date
	for my $k (keys (%$server_down)) {
		my $v = $server_down->{$k};
		service_set(@$v[0], @$v[1], "down", "force");
		delete($server_down->{$k});
	}

	# remove remaining entries for virtual servers
	foreach $nv (@OLDVIRTUAL) {
		# The below logic may be needed if l7vsadm gives all the parameters required for identifying
		# virtual service. In that case, the underlying $skip_var logic may not be required.
		# But even without this below logic, the program will work with just $skip_var logic - NTT Comware
		#if (! defined($oldsrv->{&get_virtual($nv) . " " . $nv->{protocol} . " $nv->{module_param}"})) {
		#	next;
		#}
		
		# $skip_var logic starts. Here we get difference between old virtual service
		# and existing virtual service and based on the difference, the DELETE is carried out - NTT Comware
		my $old_virtual_string=get_virtual_id_str($nv);
		my $skip_var=0;
		foreach my $nv1 (@VIRTUAL) {
			if (get_virtual_id_str($nv1) eq $old_virtual_string) {
				$skip_var=1;
				next;
			}
		}
		
		# $skip_var = 1 indicates that the old service and new service are same, thus
		# there is no need for DELETE - NTT Comware
		if ($skip_var == 1) {
			next;
		}
		# $skip_var logic ends
		
		# service still exists, remove it
		# Carry out delete of virtual server and related real server - NTT Comware
		# l7vsadm -D option deletes both the attached real/fallback servers and virtual server
		my $status = &system_wrapper_no_log("$L7VSADM -D " . $nv->{proto} . " " . 
				&get_virtual($nv) . " -m $nv->{module_key}");		
		# On success of virtual server delete
		if ($status == 0) {
			&ld_log("Removed virtual server: " . &get_virtual($nv) . " $nv->{module_key}\n");
		}
	}
}


sub ld_cmd_children
{
	my ($cmd, %children) = (@_);
	# instantiate other l7directord, if specified
	my $child;
	foreach $child (keys %children) {
		&system_wrapper("$L7DIRECTORD $child $cmd");
	}
}


sub ld_stop
{
	foreach my $v (@VIRTUAL) {
		# Commented this part since anyway $L7VSADM -D deletes both the real/fallback servers and
		# the virtual servers - NTT Comware
		#my $real = $$v{real};
		#foreach my $r (@$real) {
		#	if (defined $$r{virtual_status}) {
		#		&system_wrapper("$L7VSADM -d $$v{proto} " . &get_virtual($v) . " -r $$r{server}:$$r{port}");
		#		_status_down($v, $r);
		#		&ld_log("Removed real server: " .
		#			"$$r{server}:$$r{port} (" .
		#			#scalar(%{$v->{real_status}}) . 
		#			" x " . &get_virtual($v) );
		#	}
		#}
		
		# Carry out delete of virtual server and related real/fallback server - NTT Comware
		# l7vsadm -D option deletes both the attached real/fallback servers and virtual server
		# Added module variable for l7vsadm - NTT Comware
		# &system_wrapper("$L7VSADM -D $$v{proto} " .  &get_virtual($v));
		my $status = &system_wrapper_no_log("$L7VSADM -D $$v{proto} " .  
			&get_virtual($v) . " -m $$v{module_key}");
		
		if ($status == 0) {
			&ld_log("Removed virtual server: " .  &get_virtual($v) . " $v->{module_key}");
		}
	}
}


sub ld_main
{
	# Main failover checking code
	while (1) {
		my @real_checked;
		foreach my $v (@VIRTUAL) {
			my $real = $$v{real};
			my $virtual_id = get_virtual_id_str($v);

			# unfortunately LWP::Parallel::UserAgent
			# does not work right now for https and
			# has some major problems with http

			# my $ua = new LWP::Parallel::UserAgent;
			# $ua->redirect(0);
			# $ua->max_hosts($#$real+1);
			# $ua->max_req($#$real+1);
			REAL: foreach my $r (@$real) {
				my $real_id = get_real_id_str($r, $v);
				foreach my $tmp_id (@real_checked) {
					if($real_id eq $tmp_id) {
						&ld_debug(3, "Already checked: real server=$real_id (virtual=$virtual_id)");
						next REAL;
					}
				}
				if ($$v{checktype} eq "negotiate" || $$r{num_connects}>=$$v{num_connects}) {
					&ld_debug(2, "Checking negotiate: real server=$real_id (virtual=$virtual_id)");
					if ($$v{service} eq "http") {
						$$r{num_connects} = 0 if (check_http($v, $r));
						# my $req = new HTTP::Request(GET=>"$$r{url}");
						# $ua->register($req, \&http_received);
					} elsif ($$v{service} eq "https") {
						$$r{num_connects} = 0 if (check_https($v, $r));
					} elsif ($$v{service} eq "pop") {
						$$r{num_connects} = 0 if (check_pop($v, $r));
					} elsif ($$v{service} eq "imap") {
						$$r{num_connects} = 0 if (check_imap($v, $r));
					} elsif ($$v{service} eq "smtp") {
						$$r{num_connects} = 0 if (check_smtp($v, $r));
					} elsif ($$v{service} eq "ftp") {
						$$r{num_connects} = 0 if (check_ftp($v, $r));
					} elsif ($$v{service} eq "ldap") {
						$$r{num_connects} = 0 if (check_ldap($v, $r));
					} elsif ($$v{service} eq "nntp") {
						$$r{num_connects} = 0 if (check_nntp($v, $r));
					} elsif ($$v{service} eq "dns") {
						$$r{num_connects} = 0 if (check_dns($v, $r));
					} else {
						$$r{num_connects} = 0 if (check_none($v, $r));
					}
				# Removed the protocol part of the code since it is always tcp - NTT Comware
				# elsif ($$v{checktype} eq "connect" and $$v{protocol} ne "udp")
				} elsif ($$v{checktype} eq "connect") {
					&ld_debug(2, "Checking connect: real server=$real_id (virtual=$virtual_id)");
					check_connect($v, $r);
				} elsif ($$v{checktype} eq "off") {
					&ld_debug(2, "Checking off: No real or fallback servers to be added\n");
				} elsif ($$v{checktype} eq "on") {
					&ld_debug(2, "Checking on: Real servers are added without any checks\n");
					&service_set($v, $r, "up");
				} elsif ($$v{checktype} eq "combined") {
					&ld_debug(2, "Checking combined-connect: real server=$real_id (virtual=$virtual_id)");
					if (check_connect($v, $r)) {
						$$r{num_connects}++;
					} else {
						$$r{num_connects} = 999999;
					}
				}
				push(@real_checked, $real_id);
			}
			# $ua->wait($$v{checktimeout});
		}
		if (!check_cfgfile()) {
			sleep $CHECKINTERVAL;
		}
	}
}


# sub http_received
# # callbackfunction for Parallel::UserAgent
# {
# 	my ($content, $respone, $proto) = @_;
# 	my $req = $$respone{_request};
# 	my $url = $$req{_uri};
# 	if ($url =~ /(http\w?):\/\/([^\/:]+)(.*)/) {
# 		my ($p, $s, $u) = ($1, $2, $3);
# 		$url = "$p://$s:80$u" if ($p eq "http" && $u =~ /^\//);
# 		$url = "$p://$s:443$u" if ($p eq "https" && $u =~ /^\//);
# 	}
# 	foreach $v (@VIRTUAL) {
# 		my $real = $$v{real};
# 		foreach $r (@$real) {
# 			if ($url eq $$r{url}) {
# 				my $receive_string = $$r{receive};
# 				if (!($receive_string =~ /.+/) || $content =~ /$receive_string/) {
# 					service_set($v, $r, "up");
# 				} else {
# 					service_set($v, $r, "down");
# 				}
# 			}
# 		}
# 	}
# 	return C_ENDCON;
# }


sub check_http
{
	use LWP::UserAgent;
	use LWP::Debug;
	if($DEBUG > 2) {
		LWP::Debug::level('+');
	}
	my ($v, $r) = @_;

	$$r{url} =~ /http:\/\/([^:\/]+)(:([^\/]+))?(\/.*)/;
	my $host = $1;
	#my $port = $3;
	my $uri = $4;
	my $virtualhost = (defined $$v{virtualhost} ? $$v{virtualhost} : $host);

	&ld_debug(2, "Checking http: url=\"$$r{url}\" "
		. "virtualhost=\"$virtualhost\"");
	
	my $ua = new LWP::UserAgent();
	$ua->timeout($$v{negotiatetimeout});
	my $h = new  HTTP::Headers("Host" => $virtualhost);
	my $req = new HTTP::Request("GET", "$$r{url}", $h);
	my $res;
	{
		# LWP makes unguarded calls to eval
		# which throw a fatal exception if they fail
		# Needless to say, this is completely stupid.
		local $SIG{'__DIE__'} = "DEFAULT";
		$res = $ua->request($req);
	}
	my $recstr = $$r{receive};
	if ($res->is_success && (!($recstr =~ /.+/) || 
				$res->content =~ /$recstr/)) {
		service_set($v, $r, "up");
		&ld_debug(2, "check_http: $$r{url} is up\n");
		return 1;
	} else {
		service_set($v, $r, "down");
		&ld_debug(3, "Headers " .  $res->headers->as_string);
		&ld_debug(2, "check_http: $$r{url} is down\n");
		return 0;
	}
}


sub check_smtp
{
	require Net::SMTP;
	my ($v, $r) = @_;
	my $port=(defined $$v{checkport}?$$v{checkport}:$$r{port});
	
	&ld_debug(2, "Checking http: server=$$r{server} port=$port");
	
	my $smtp = new Net::SMTP($$r{server}, Port => $port,
			Timeout => $$v{negotiatetimeout});
	if ($smtp) {
		$smtp->quit;
		service_set($v, $r, "up");
		return 1;
	} else {
		service_set($v, $r, "down");
		return 0;
	}
}


sub check_pop
{
	require Net::POP3;
	my ($v, $r) = @_;
	my $port=(defined $$v{checkport}?$$v{checkport}:$$r{port});
	
	&ld_debug(2, "Checking pop server=$$r{server} port=$port");
	
	my $pop = new Net::POP3($$r{server}, Port => $port, 
			Timeout => $$v{negotiatetimeout});
	if (!$pop) {
		service_set($v, $r, "down");
		return 1;
	}

	if($$v{login} ne "") {
		$pop->user($$v{login});
		my $num = $pop->pass($$v{passwd});
		if (!defined($num)) {
			$pop->quit();
			service_set($v, $r, "down");
			return 1;
		}
	}
		
	$pop->quit();
	service_set($v, $r, "up");
	return 0;
}


sub check_imap
{
	require Mail::IMAPClient;
	my ($v, $r) = @_;
	my $port=(defined $$v{checkport}?$$v{checkport}:$$r{port});
	
	&ld_debug(2, "Checking imap server=$$r{server} port=$port");
	
	my $imap = new Mail::IMAPClient(Server => $$r{server}, Port=>$port,
					Timeout => $$v{negotiatetimeout},
					User => $$v{login}, 
					Password => $$v{passwd});
	if (!$imap) {
		service_set($v, $r, "down");
		return 1;
	} 

	if($$v{login} ne "") {
		my $authres = $imap->login();
		$imap->logout();
		if (!$authres) {
			service_set($v, $r, "down");
			return 1;
		} 
	}

	$imap->logout();
	service_set($v, $r, "up");
	return 0;
}

sub check_ldap
{
	my ($v, $r) = @_;
	require Net::LDAP;
	my $port=(defined $$v{checkport}?$$v{checkport}:$$r{port});

	&ld_debug(2, "Checking ldap server=$$r{server} port=$port");
	
	my $recstr = $$r{receive};
	my $ldap = Net::LDAP->new("$$r{server}", port => $port,
					timeout => $$v{negotiatetimeout});
	if(!$ldap) {
		service_set($v, $r, "down");
		&ld_debug(4, "Connection failed");
		return 0;
	}
		
	my $mesg = $ldap->bind ;
	if ($mesg->is_error) {
		service_set($v, $r, "down");
		&ld_debug(4, "Bind failed");
		return 0;
	}

	&ld_debug(4, "Base : " . substr($$r{request},1));
	my $result = $ldap->search (
		base	=> substr($$r{request},1) . "",
		scope	=> "base",
		filter	=> "(objectClass=*)"
		);

	if($result->count != 1) {
		service_set($v, $r, "down");
		&ld_debug(2, "Count failed : " . $result->count);
		return 0;
	}
		
	my $href = $result->as_struct;
	my @arrayOfDNs  = keys %$href ;
	my $recstr = $$r{receive} ;
	if (!($recstr =~ /.+/) || @arrayOfDNs[0] =~ /$recstr/) {
		service_set($v, $r, "up");
		return 1;
	} else {
		service_set($v, $r, "down");
		&ld_debug(4,"Message differs : " . ", " . $$r{receive} 
				. ", " . @arrayOfDNs[0] . ".");
		return 0;
	}
}


sub check_https_child
{
	my ($v, $r) = @_;
	require Net::SSLeay;
	$Net::SSLeay::trace = $DEBUG;
	$$r{url} =~ /https:\/\/([^:\/]+)(:([^\/]+))?(\/.*)/;
	my $host = $1;
	my $port = $3;
	my $uri = $4;
	unless (defined $port) {
		$port=(defined $$v{checkport}?$$v{checkport}:$$r{port})
	}
	my $virtualhost = (defined $$v{virtualhost} ? $$v{virtualhost} : $host);
	my ($page, $errors, $cert, $head, $body, $response, $result);
	my $msg = "GET $uri HTTP/1.0" . $CRLF
	        . "Host: " . $virtualhost . $CRLF
		. "Accept: */*" . $CRLF . $CRLF;

	&ld_debug(2, "Checking https url=\"$$r{url}\" "
		. "virtualhost=\"$virtualhost\"");
	
	eval {
		local $SIG{__WARN__};
		local $SIG{'__DIE__'} = "DEFAULT";
		local $SIG{'ALRM'} = sub { die "Timeout Alarm" };
		alarm $$v{negotiatetimeout};
		&ld_debug(2, "Testing: $host, $port, $uri");
		($page, $errors, $cert)  = &Net::SSLeay::sslcat($host,
		               $port, $msg);
		alarm 0; # Cancel the alarm
		($head, $body) = split /\s?\n\s?\n/, $page, 2;
		($response, $head) = split /\s?\n/, $head, 2;
		&ld_debug(2, "Result: $response");
		my $recstr = $$r{receive};
		if($result =~ /error/i ||
				($recstr =~ /.+/ && !($body =~ /$recstr/))) {
			alarm(0);
			die("$result");
		}
	};

	if ($@) {
		return 1;
	}
	return 0;
}


sub check_https
{
	my ($v, $r) = @_;

        # The SSLeay module seems to have a memory leak
	# that I can't find, so run it in a child process
	# to prevent the parent from contiuously growing in size.
	my $pid;
	my $status;
	local $SIG{'CHLD'} = "IGNORE";
	
	$pid = fork();
	if ($pid) {
		#parent
		if (wait) {
			$status = $? >> 8;
		}
		else {
			#no child for some reason
			return 1;
		}
	}
	elsif (defined $pid) {
		exit check_https_child($v, $r);
	}
	else {
		#error
		return 1;
	}

	&ld_debug(2, "Status: $status");
	if ($status ne 0) {
		service_set($v, $r, "down");
		return 0;
	}
	service_set($v, $r, "up");
	return 1;
}



sub check_nntp
{
        use IO::Socket;
        use IO::Select;
        my ($v, $r) = @_;
        my $sock;
        my $s;
        my $buf;
	my $port=(defined $$v{checkport}?$$v{checkport}:$$r{port});

	&ld_debug(2, "Checking nntp server=$$r{server} port=$port");
	
        unless ($sock = IO::Socket::INET->new(PeerAddr => $$r{server},
                PeerPort => $port, Proto => 'tcp',
                TimeOut => $$v{negotiatetimeout})) {
                service_set($v, $r, "down");
                return 0;
        }
        $s = IO::Select->new();
        $s->add($sock);
        if (scalar($s->can_read($$v{negotiatetimeout})) == 0) {
                service_set($v, $r, "down");
        } else {
                sysread($sock, $buf, 64);
                if ($buf =~ /^2/) {
                        service_set($v, $r, "up");
                } else {
                        service_set($v, $r, "down");
                }
        }
        $s->remove($sock);
        $sock->close;

        return 0;
}


sub check_connect
{
	my ($v, $r) = @_;
	my $port=(defined $$v{checkport}?$$v{checkport}:$$r{port});

	eval {
		local $SIG{'__DIE__'} = "DEFAULT";
		local $SIG{'ALRM'} = sub { die "Timeout Alarm" };
		&ld_debug(4, "Timeout is $$v{checktimeout}");
		alarm $$v{checktimeout};
		my $result = &ld_open_socket($$r{server}, $port, $$v{protocol});
		if ($result == 0) {
			# Failure to open the socket
			alarm(0);
			die("Couldn't open socket to $$r{server}:$port");
		} else {
			&ld_debug(3, "Connected to $1 (port $port)");
		}
		alarm 0; # Cancel the alarm
	};
	if ($@) {
		&service_set($v, $r, "down");
		&ld_debug(3, "Deactivated service $$r{server}:$$r{port}: $@");
		return 0;
	} else {
		&service_set($v, $r, "up");
		&ld_debug(3, "Activated service $$r{server}:$$r{port}");
		return 1;
	}
}


sub check_ftp
{
	require Net::FTP;
	my ($v, $r) = @_;
	my $ftp;
	my $memory;
	my $port=(defined $$v{checkport}?$$v{checkport}:$$r{port});

	&ld_debug(2, "Checking ftp server=$$r{server} port=$port");
	
	open(MEMORY,'>', \$memory);

	unless ($ftp = Net::FTP->new("$$r{server}:$port", 
			Timeout=>$$v{negotiatetimeout})) {
		service_set($v, $r, "down");
		return 0;
	}
	$ftp->login($$v{login}, $$v{passwd});
	$ftp->cwd("/");
	$ftp->binary();
	$ftp->pasv();
	$ftp->get("$$r{request}", *MEMORY);
	$ftp->quit();

	close(MEMORY);

	if ($memory =~ /$$r{receive}/) {
		service_set($v, $r, "up");
		return 1;
	}

	service_set($v, $r, "down");
	return 0;
}


sub check_dns
{
	my $res;
	my $query;
	my $rr;
	my $request;
	my ($v,$r) = @_;
	{
		# Net::DNS makes ungaurded calls to eval
		# which throw a fatal exception if they fail
		# Needless to say, this is completely stupid.
		local $SIG{'__DIE__'} = "DEFAULT";
		require Net::DNS;
	}
	$res = new Net::DNS::Resolver;
	if($DEBUG > 2) {
		$res->debug(1);
	}

	$$r{"request"} =~ m/^\/?(.*)/;
	$request=$1;

	&ld_debug(2, "Checking dns: request=\"$request\" receive=\""
		. $$r{"receive"} . "\"\n");

	eval {
		 local $SIG{'__DIE__'} = "DEFAULT";
		 local $SIG{'ALRM'} = sub { die "timeout\n"; };
		 alarm($$v{checktimeout});
		 $res->nameservers($$r{server});
		 $query = $res->search($request);
		 alarm(0);
	};
 
	if (@$ eq "timeout\n" or ! $query) {
		 service_set($v,$r,"down");
		 return 0;
	}
 
	foreach $rr ($query->answer) {
	        if (($rr->type eq "A" and $rr->address eq $$r{"receive"}) or
	            ($rr->type eq "PTR" and $rr->ptrdname eq $$r{"receive"})) {
	         	service_set($v,$r,"up");
	         	return 1;
		}
        }
 
	service_set($v,$r,"down");
	return 0;
}


# check_none
# Dummy function to check service if service type is none.
# Just activates the real server

sub check_none
{
	my ($v, $r) = @_;

	&ld_debug(2, "Checking none");
	
	service_set($v, $r, "up");
	return 1;
}


# service_set
# Used to bring up and down real servers.
# This is the function you should call if you want to bring a real 
# server up or down.
# This function is safe to call regrdless of the current state of a 
# real server.
# Do _not_ call _service_up or _service_down directly.
# pre: v: virtual that the real service belongs to
#         Only used to determine the protocol of the service
#      r: real server to take down
#      state: up or down
#             up to bring the real service up
#             down to bring the real service up
# post: The real server is brough up or down for each virtual service
#       it belongs to.
# return: none

sub service_set()
{
	my ($v, $r, $state, $force) = @_;

	my ($real, $virtual, $virt);

        # Find the real server in @REAL
	foreach $real (@REAL) {
		if($real->{"real"} eq get_real_id_str($r, $v)) {
			$virtual = $real->{"virtual"};
			last;
		}
	}
	return unless (defined($virtual));

	# Check each virtual service for the real server and make
	# changes as neccessary
	foreach $v (@VIRTUAL){
	        # Use found rather than relying on tmp_id being
		# set when we leave the foreach loop. There
		# seems to some weirdness in Perl (5.6.0 on Redhat 7.2)
	        my $found = 0;
		my $tmp_id;
		my $virtual_id = get_virtual_id_str($v);
		foreach $tmp_id (@$virtual) {
			if($virtual_id eq $tmp_id) {
				$found = 1;
				last;
			}
		}
		if ($found == 1) {
			if ($state=~/up/i) {
				_service_up($v, $r, $force);
				&ld_debug(2, "Enabled server=$$r{server}");
			} elsif ($state=~/down/i) {
				_service_down($v, $r, $force);
				&ld_debug(2, "Disabled server=$$r{server}");
			}
		}
	}
}


# _remove_service
# Remove a real server by either making it quiescent or deleteing it
# Should be called by _service_down or fallback_off
# I.e. If you want to change the state of a real server call service_set.
#      If you call this function directly then l7directord will lose track
#      of the state of real servers.
# If the real server exists (which it should) make it quiescent or
# delete it, depending on the global and per virtual service quiescent flag. 
# If it # doesn't exist, just leave it as it will be added by the 
# _service_up code as appropriate.
# pre: v: reference to virtual service to with the real server belongs
#      rservice: service to restore. Of the form server:port for tcp
#      rforw: Forwarding mechanism of service. Should be only "-m"
#	rforw is kept as it is, even though not used - NTT Comware
#      tag: Tag to use for logging. Should be either "real" or "fallback"
# post: real service is taken up from the respective virtual service
#       if it is inactive
# return: none

# Commented out parts of the code, to make the logic much easier since the current
# l7vsadm does not get the full module parameters - NTT Comware

sub _remove_service {
	my ($v, $rservice, $rforw, $tag) = (@_);

        my $oldsrv;
        my $ov;
        # Commented out since not used - NTT Comware
        #my $or;
        my $l7vsadm_args;
        my $log_args;
        # Added variables - NTT Comware
        my $l7vsadm_args_key;
        my $log_args_key;
	my $virtual_str;
	# Commented out the $old_service variable of the code since real server port is not
        # made equal to the virtual server port - NTT Comware
	#my $old_rservice;
	my $is_quiescent;

	$virtual_str = &get_virtual($v);

        $oldsrv=&ld_read_l7vsadm();
        # Added module parameter for l7vsadm - NTT Comware
        # $ov=$oldsrv->{$virtual_str . " " . $v->{"protocol"}};
        $ov=$oldsrv->{$virtual_str . " " . $v->{"protocol"} . " $v->{module_param}"};
	if(!defined($ov)){
		return;
	}

	if ($tag ne "fallback" 
			and ((defined $$v{quiescent} 
					and $$v{quiescent} eq "yes")
				or (!defined($$v{quiescent}) 
					and $QUIESCENT eq "yes"))){
		$is_quiescent = "quiescent";
	}

	# Commented out since not used - NTT Comware
        #$or=$ov->{"real"}->{$rservice};

	# Commented out this part of the code that makes the real port = virtual service port
	# Initially for L4 ldirectord this was present because that used to also handle services
	# other than masq. Now it is not needed
	# The real server port as per the configuration file can be retained - NTT Comware
	#if(!defined($or)) {
	#	$old_rservice = $rservice;
	#	$rservice =~ /(.*):(.*)/;
	#	$rservice = $1;
	#	$virtual_str =~ /(.*):(.*)/;
	#	$rservice .= ":" . $2;
        #	$or=$ov->{"real"}->{$rservice};
	#}

        # Commented out since now l7vsadm does not return full parameters.
        # When l7vsadm returns full parameters, the same can be edited and also the
        # weight parameter can be removed - NTT Comware
        #if((!defined($or) and !defined($is_quiescent)) or 
	#		(defined($is_quiescent) and defined($or) and
	#			$or->{"weight"} eq 0 and 
	#			get_forward_flag($or->{"forward"}) eq $rforw)){
	#	return;
	#}
	
	# Added the module part as the arguments for l7vsadm - NTT Comware
	#$l7vsadm_args = "$$v{proto} " . $virtual_str . " -r $rservice";
	$l7vsadm_args = "$$v{proto} " . $virtual_str . " -m $$v{module}" . " -r $rservice";
	$l7vsadm_args_key = "$$v{proto} " . $virtual_str . " -m $$v{module_key}" . " -r $rservice";
        $log_args = "$tag server: $rservice ";
        
        # Commented out the $old_service part of the code since anyway real server port is not
        # made equal to the virtual server port - NTT Comware
	#if(defined($old_rservice)) {
	#	$log_args .= "mapped from $old_rservice "
	#}
	
	$log_args_key = $log_args . "( x $virtual_str $v->{module_key})";
	$log_args .= "( x $virtual_str $v->{module})";

	# Commented out since now l7vsadm does not return full parameters.
        # When l7vsadm returns full parameters, the same can be edited and also the
        # weight parameter can be removed.
        # A seperate logic follows after the commented lines - NTT Comware
	#if(defined($is_quiescent)) {
	#	if (defined($or)) {
	#         	&system_wrapper("$IPVSADM -e "
	#				. "$ipvsadm_args $rforw -w 0");
	#        	&ld_log("Quiescent $log_args (Weight set to 0)");
	#	}
	#	else {
        #        	&system_wrapper("$IPVSADM -a "
	#				. "$ipvsadm_args $rforw -w 0");
	#        	&ld_log("Quiescent $log_args (Weight set to 0)");
	#	}
        #}
	#else {
        #        &system_wrapper("$IPVSADM -d $ipvsadm_args");
	#        &ld_log("Deleted $log_args");
	#}
	
	# Now the new logic just tries to EDIT/ADD if the quiescent is YES
	# and it tries to DELETE if the quieiscent is NO - NTT Comware
	if (defined($is_quiescent)) {
		my $result = &system_wrapper_no_log("$L7VSADM -e " . "$l7vsadm_args");
		if ($result == 0) {
			&ld_log("Edited $log_args");
		} else {
			&system_wrapper("$L7VSADM -a " . "$l7vsadm_args");
			&ld_log("Added $log_args");
		}
        }
	else {
                my $result = &system_wrapper_no_log("$L7VSADM -d $l7vsadm_args_key");
                if ($result == 0) {
                	&ld_log("Deleted $log_args_key");
                }
	}
}


# _restore_service
# Make a restore a real server. The opposite of _quiescent_server.
# Should be called by _service_up or fallback_on
# I.e. If you want to change the state of a real server call service_set.
#      If you call this function directly then l7directord will lose track
#      of the state of real servers.
# If the real server exists (which it should) make it quiescent. If it
# doesn't exist, just leave it as it will be added by the _service_up code
# as appropriate.
# pre: v: reference to virtual service to with the real server belongs
#      rservice: service to restore. Of the form server:port for tcp
#      rforw: Forwarding mechanism of service. Should be "-m"
#      rwght: Weight of service. Should be of the form "<weight>"
#             e.g. "1"
#      tag: Tag to use for logging. Should be either "real" or "fallback"
# post: real service is taken up from the respective virtual service
#       if it is inactive
# return: none

# Commented out parts of the code, to make the logic much easier since the current
# l7vsadm does not get the full module parameters - NTT Comware

sub _restore_service {
	my ($v, $rservice, $rforw, $rwght, $tag) = (@_);

        # Commented out since it is not used now - NTT Comware
        #my $oldsrv;
        #my $ov;
        #my $or;
        my $l7vsadm_args;
        my $log_args;

	# Removed weight setting parameter, since l7vsadm does not support weight
	# Removed forward mechanism parameter, since l7vsadm does not support setting of forward
	# Added the module part as the arguments for l7vsadm - NTT Comware
	#$l7vsadm_args = "$$v{proto} " . &get_virtual($v) 
        #                . " -r $rservice $rforw -w $rwght";
        $l7vsadm_args = "$$v{proto} " . &get_virtual($v) . " -m $$v{module}" . " -r $rservice";
        
	$log_args = "$tag server: $rservice " . "( x " .  &get_virtual($v) . " $v->{module})";

	# Commented out since now l7vsadm does not return full parameters.
	# When l7vsadm returns full parameters, the same can be edited and also the
	# weight parameter can be removed.
        # A seperate logic follows after the commented lines - NTT Comware
        #$oldsrv=&ld_read_ipvsadm();
        #$ov=$oldsrv->{&get_virtual($v) . " " . $v->{"protocol"}};
        #if(defined($ov)){
        #        $or=$ov->{"real"}->{$rservice};
        #}
        #if(defined($or)){
        #        unless("-r " . $or->{"weight"} eq $rwght and
        #               $or->{"forward"} eq $rforw){
        #                &system_wrapper("$IPVSADM -e $ipvsadm_args");
	#                &ld_log("Restored $log_args (Weight set to $rwght)");
        #        }
        #}
        #else {
        #        &system_wrapper("$IPVSADM -a $ipvsadm_args");
	#        &ld_log("Added $log_args (Weight set to $rwght)");
        #}
        
        # Now the new logic just tries to EDIT/ADD. If EDIT is not successful then
        # ADD is carried out - NTT Comware
	my $result = &system_wrapper_no_log("$L7VSADM -e $l7vsadm_args");
	if ($result == 0) {
		&ld_log("Restored $log_args");
	} else {
		$result = &system_wrapper("$L7VSADM -a $l7vsadm_args");
		&ld_log("Added $log_args");
	}
}


# Set the status of a server as up
# Should only be called from _service_up or _ld_start

sub _status_up
{
	my ($v, $r, $is_fallback) = (@_);

	my $virtual_id = get_virtual_id_str($v);
	my $real_id = get_real_id_str($r, $v);

	if (defined($is_fallback)) {
		if (defined($v->{real_status}) or
				(defined($v->{fallback_status}) and
				$v->{fallback_status}->{"$real_id"})) {
			return undef;
		}
	}
	else {
		if (defined ($v->{real_status}) and
				$v->{real_status}->{"$real_id"}) {
			return undef;
		}
	}

	$r->{virtual_status}->{"$virtual_id"} = 1;
	if (defined $is_fallback) {
		$v->{fallback_status}->{"$real_id"} = 1;
	}
	else {
		$v->{real_status}->{"$real_id"} = 1;
	}

	return 1;
}

# Set the status of a server as down
# Should onlu be called from _service_down or _ld_stop

sub _status_down
{
	my ($v, $r, $is_fallback) = (@_);

	my $virtual_id = get_virtual_id_str($v);
	my $real_id = get_real_id_str($r, $v);

	if (defined($is_fallback)) {
		if (! defined($v->{real_status}) or
				! defined($v->{fallback_status}) or
				! $v->{fallback_status}->{"$real_id"}) {
			return undef;
		}
	}
	else {
		if (! defined ($v->{real_status}) or
				! $v->{real_status}->{"$real_id"}) {
			return undef;
		}
	}

	if (defined($is_fallback)) {
		delete $v->{fallback_status}->{"$real_id"};
		if (! %{$v->{fallback_status}}) {
			$v->{fallback_status} = undef;
		}
	}
	else {
		delete $v->{real_status}->{"$real_id"};
		if (! %{$v->{real_status}}) {
			$v->{real_status} = undef;
		}
	}

	delete $r->{virtual_status}->{"$virtual_id"};
	if (! %{$r->{virtual_status}}) {
		$r->{virtual_status} = undef;
	}

	return 1;
}




# _service_up
# Bring a real service up if it is down
# Should be called by service_set only
# I.e. If you want to change the state of a real server call service_set.
#      If you call this function directly then l7directord will lose track
#      of the state of real servers.
# pre: v: reference to virtual service to with the real server belongs
#      r: refernece to the real server to take down
# post: real service is taken up from the respective virtual service
#       if it is inactive
# return: none

sub _service_up
{
	my ($v, $r, $force) = (@_);

	if (! _status_up($v, $r) and ! defined($force)) {
		return;
	}
	
        &_restore_service($v, $r->{server} . ":" . $r->{port}, 
                                  $r->{forw}, $r->{wght}, "real");

	&fallback_off($v);
}


# _service_down
# Bring a real service down if it is up
# Should be called by service_set only
# I.e. if you want to change the state of a real server call service_set.
#      If you call this function directly then l7directord will lose track
#      of the state of real servers.
# pre: v: reference to virtual service to with the real server belongs
#      r: refernece to the real server to take down
# post: real service is taken down from the respective virtual service
#       if it is active
# return: none

sub _service_down
{
	my ($v, $r, $force) = @_;

	if (! _status_down($v, $r) and ! defined($force)) {
		return;
	}

        &_remove_service($v, $r->{server} . ":" . $r->{port}, 
                          $r->{forw}, "real");

	&fallback_on($v);
}


# fallback_on
# Turn on the fallback server for a virtual service if it is inactive
# pre: v: virtual to turn fallback service on for
# post: fallback server is turned on if it was inactive
# return: none

sub fallback_on
{
	my ($v, $force) = (@_);

	my $fallback=&fallback_find($v);

	if (! defined($fallback) or (! _status_up($v, $fallback, "fallback") 
			and ! defined($force))) {
		return;
	}

	&_restore_service($v, $fallback->{server}, 
			get_forward_flag($fallback->{forward}), 
				"1", "fallback");
}


# fallback_off
# Turn off the fallback server for a virtual service if it is active
# pre: v: virtual to turn fallback service off for
# post: fallback server is turned off if it was active
# return: none

sub fallback_off
{
	my ($v, $force) = (@_);

	my $fallback=&fallback_find($v);

	if (! defined($fallback) or (! _status_down($v, $fallback, "fallback") 
			and ! defined($force))) {
		return;
	}

	&_remove_service($v, $fallback->{server},
			get_forward_flag($fallback->{forward}),
				"fallback");
}


# fallback_find
# Determine the fallback for a virtual service
# pre: virtual: reference to a virtual service
# post: none
# return: $virtual->{"fallback"} if defined
#         else $FALLBACK->{$virtual->{"protocol"}} if defined
#         else undef

sub fallback_find
{
	my ($virtual) = (@_);

	if( defined $virtual->{"fallback"} ) {
		return($virtual->{"fallback"});
	} elsif ( defined($FALLBACK) ) {
		return($FALLBACK->{$virtual->{"protocol"}});
	}

	return undef;
}


sub check_cfgfile
{
	my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, 
		$size, $atime, $mtime) = stat($CONFIG);
	my ($status);
	return if ($stattime==$mtime);
	$stattime = $mtime;
	use Digest::MD5 qw(md5 md5_hex);
	my $ctx = Digest::MD5->new;
	open(CFGFILE, "<$CONFIG") || &config_error(0, "can not open file $CONFIG");
	$ctx->addfile(*CFGFILE);
	close(CFGFILE);
	my $digest = $ctx->hexdigest;
	if (defined $checksum && $checksum ne $digest) {
		&ld_log("Configuration file '$CONFIG' has changed on disk");
		if ($AUTOCHECK eq "yes") {
			&ld_log(" - reread new configuration");
			&reread_config();
		} else {
			&ld_log(" - ignore new configuration\n");
		}
		if (-x $CALLBACK) {
			&system_wrapper("$CALLBACK $CONFIG");
		}
		$status = 1;
	}
	$checksum = $digest;

	return $status;
}


# ld_openlog
# Open logger
# make log rotation work
# pre: none
# post: If logger is a file, it opened and closed again as a test
#       If logger is syslog, it is opened so it can be used without
#       needing to be opened again.
#       Otherwiese, nothing is done.
# return: 0 on success
#         1 on error
sub ld_openlog
{
	if (defined $opt_d or $SUPERVISED) {
		# Instantly do nothing
		return(0);
	}	
	if( $L7DIRLOG =~ /^\/(.*)/ ) {
	    # Open and close the file as a test.
	    # We open the file each time we want to log to it
	    unless (open(LOGFILE, ">>$L7DIRLOG") and close(LOGFILE)) {
		return 1;
	    }
	}
	else
	{
	    # Assume L7DIRLOG is a logfacility, log to syslog
	    setlogsock( "unix" );
	    openlog( "l7directord", "pid", "$L7DIRLOG" );
	}
	return(0);
}

# ld_log
# Log a message.
# pre: message: Message to write
# post: message and timetsamp is written to loged
#       If logger is a file, it is opened and closed again as a 
#       primative means to make log rotation work
# return: 0 on success
#         1 on error
sub ld_log
{
	my ($message) = (@_);

        my $now = localtime();

	&ld_debug(2, $message);
	chomp $message;
	if (defined $opt_d) {
		print STDERR "$message\n";
	} elsif ($SUPERVISED) {
		print "[$now] $message\n";
	} elsif ( $L7DIRLOG =~ /^\/(.*)/ ) {
		unless (open(LOGFILE, ">>$L7DIRLOG")
				and print LOGFILE "[$now|$CFGNAME] $message\n"
				and close(LOGFILE)) {
			print STDERR "$message\n";
	    		return 1;
	    	}
	}
	else {
	    # Assume L7DIRLOG is a logfacility, log to syslog
	    syslog( "info", "$message" );
	}
	return(0);
}


# ld_debug
# Log a message to a STDOUT.
# pre: priority: priority of message
#      message: Message to write
# post: message is written to STDOUT if $DEBUG >= priority
# return: none

sub ld_debug
{
	my ($priority, $message) = (@_);

	if ( $DEBUG >= $priority ) {
		chomp $message;
		print STDERR "DEBUG${priority}: $message\n";
	}
}


# system_wrapper
# Wrapper around system() to log errors
# pre: LIST: arguments to pass to system()
# post: system() is called and if it returns non-zero a failure 
#       message is logged
# return: return value of system()

sub system_wrapper
{
	my (@args)=(@_);

	my $status;

        &ld_log("Running system(@args)") if $DEBUG>2;
	$status = system(@args);
	if($status != 0) {
		&ld_log("system(@args) failed");
	}

	return($status)
}


# system_wrapper_no_log sub-routine catches specific error messages for l7vsadm execution
# This is added specially for l7vsadm - NTT Comware
# If the error message thrown by l7vsadm is changed then this sub routine has to be changed too
# Currently only error messages "No such virtual service" and "No such real server" are handled

# system_wrapper_no_log - NTT Comware
# Wrapper around back-tick to log errors
# Back-tick is used since when using system() we have to redirect error message to some temporary file
# whereas, back-tick easily can be used to redirect error message to some list variable
# pre: LIST: arguments to pass to the back-tick function
# 
# return: returns values. 0 indicates no error, other values indicate other error

sub system_wrapper_no_log
{
	my (@args)=(@_);

	my $status;
	my @error_message_list=();
	my $error_message;
	
	# STDOUT is bypassed and only the STDERR message is redirected to @error_message
	# $? holds the status of the executed command, Non-zero value indicates error
	@error_message_list=`@args 2>&1 1>/dev/null`;
	$status=$?;
	
	if ($status == 0)
	{
		&ld_log("Running system(@args)") if $DEBUG>2;
	} else {
		# Convert the list into a scalar string $error_message with a space between each element
		$error_message="@error_message_list";
		
		if (($error_message=~/No such virtual service/) 
			|| ($error_message=~/No such real server/)) {
		return($status);
		} else {
			&ld_log("Running system(@args)") if $DEBUG>2;
			&ld_log("system(@args) failed");
		}
	}

	return($status);
}


# exec_wrapper
# Wrapper around exec() to log errors
# pre: LIST: arguments to pass to exec()
# post: exec() is called and if it returns non-zero a failure 
#       message is logged
# return: return value of exec() on failure
#         does not return on success

sub exec_wrapper
{
	my (@args)=(@_);

	my $status;

        &ld_log("Running exec(@args)") if $DEBUG>2;
	$status = exec(@args);
	if($status != 0) {
		&ld_log("exec(@args) failed");
	}

	return($status)
}


# ld_rm_file
# Remove a file, symink, or anything that isn't a directory
# and exists
# pre: filename: file to delete
# post: If filename does not exist or is a directory an
#       error state is reached
#       Else filename is delete
#       If $DEBUG >=2 errors are logged
# return: 0 on success
#         -1 on error

sub ld_rm_file
{
	my ($filename)=(@_);

	my ($status);

	if(-d "$filename"){
		&ld_debug(2, "ld_rm_file: $filename is a directory, skipping");
		return(-1);
	}
	if(! -e "$filename"){
		&ld_debug(2, "ld_rm_file: $filename doesn't exist, skipping");
		return(-1);
	}
	$status = unlink($filename);
	if($status!=1){
		&ld_debug(2, "ld_rm_file: Error deleting: $filename: $!");
	}
	return(($status==1)?0:-1)
}


# is_octet
# See if a number is an octet, that is >=0 and <=255
# pre: alleged_octet: the octect to test
# post: alleged_octect is checked to see if it is valid
# return: 1 if the alleged_octet is an octet
#         0 otherwise

sub is_octet
{
	  my ($alleged_octet)=(@_);

	  if($alleged_octet<0){ return 0; }
	  if($alleged_octet>255){ return 0; }

	  return(1);
}


# is_ip
# Check that a given string is an IP address
# pre: alleged_ip: string representing ip address
# post: alleged_ip is checked to see if it is valid
# return: 1 if alleged_ip is a valid ip address
#         0 otherwise

sub is_ip
{
	  my ($alleged_ip)=(@_);

	  #If we don't have four, . delimited numbers then we have no hope
	  unless($alleged_ip=~m/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) { return 0; }

	  #Each octet mist be >=0 and <=255
	  unless(&is_octet($1)){ return 0; }
	  unless(&is_octet($2)){ return 0; }
	  unless(&is_octet($3)){ return 0; }
	  unless(&is_octet($4)){ return 0; }

	  return(1);
}


# ip_to_int
# Turn an IP address given as a dotted quad into an integer
# pre: ip_address: string representing IP address
# post: post ip_address is converted to an integer
# return: -1 if an error occurs
#         integer representation of IP address otherwise

sub ip_to_int
{
	  my ($ip_address)=(@_);

	  unless(&is_ip($ip_address)){ return(-1); }
	  unless($ip_address=~m/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/){ return(-1); }

	  return(((((($1<<8)+$2)<<8)+$3)<<8)+$4);
}


# int_to_ip
# Turn an IP address given as a dotted quad into an integer
# pre: ip_address: string representing IP address
# post: Decimal is converted to a dotted quad
# return: -1 if an error occurs
#        integer representation of IP address otherwise

sub int_to_ip
{
	my ($ip_address)=(@_);

	my $result = "";

	return(sprintf(
		"%d.%d.%d.%d",
		($ip_address>>24)&255,
		($ip_address>>16)&255,
		($ip_address>>8)&255,
		$ip_address&255
	));
}


# get_virtual
# Get the service for a virtual
# pre: nv: virtual to get the service for
# post: none
# return: fwmark of service if it is a fwm service
#         ip_address:port otherwise

sub get_virtual
{
	my ($nv) = (@_);

	# Removed out fwm related code since it is not used - NTT Comware
	#if ($nv->{"protocol"} eq "fwm"){
	#	return $nv->{"fwm"};
	#} else {
	if ($nv->{"protocol"} eq "tcp"){
        	return $nv->{"server"} . ":" . $nv->{"port"};
	}
}


# get_real_id_str
# Get an id string for a real server
# pre: r: Real service.
#      protocol: protocol of the real service
#                tcp
#      service: type of service
# post: none
# return: Id string for the real server

sub get_real_id_str
{
	my ($r, $v) = (@_);

	my $request = "";
	my $receive = "";
	my $checkport = "";
	my $check;
	my $real;

	if(defined($r->{"request"})) {
		$request = $r->{"request"};
	}
	else {
		$request = $v->{"request"};
	}

	if(defined($r->{"receive"})) {
		$receive = $r->{"receive"};
	}
	else {
		$receive = $v->{"receive"};
	}

	if($v->{"checktype"} eq "negotiate" || 
			$v->{"combined"} eq "negotiate") {
		$check = $v->{"checktype"} . ":" . $v->{"service"};
	}
	else {
		$check = $v->{"checktype"};
	}

	if(defined($v->{"checkport"})) {
		$checkport = $v->{"checkport"};
	}

	
	# Since l7vsadm does not support weight, the weight part of the code is commented - NTT Comware
        $real    = $check . ":" . $v->{"protocol"} . ":" 
	         . $r->{"server"} . ":" . $r->{"port"} . ":" 
		 #. $checkport . ":" . $r->{"weight"} . ":"
		 . $checkport . ":"
		 . quotemeta($request) . ":" . quotemeta($receive);
}


# get_virtual_id_str
# Get an id string for a virtual service
# pre: v: Virtual service
# post: none
# return: Id string for the virtual service

sub get_virtual_id_str
{
	my ($v) = (@_);

	# Adding module key component for virtual id string - NTT Comware
	#my $virtual = $v->{"protocol"} . ":" .  &get_virtual($v);
	my $virtual = $v->{"protocol"} . ":" .  &get_virtual($v) . ":" . $v->{module_key};
}


# get_forward_flag
# Get the l7vsadm flag corresponging to a forwarding mechanism
# pre: forward: Name of forwarding mechanism.
#               Should be masq
# post: none
# return: l7vsadm flag corresponding to the forwading mechanism
#         " " if $forward is unknown

sub get_forward_flag
{
        my ($forward) = (@_);

        unless(defined($forward)) {
                return(" ");
        }

	if ($forward eq "masq") {
		return("-m");
	} 
	# Removed gate/ipip part of the code since l7vsadm supports only masq - NTT Comware
        #elsif ($forward eq "gate") {
	#	return("-g");
	#} 
        #elsif ($forward eq "ipip") {
	#	return("-i");
	#} 

	return(" ");
}


# ld_exit
# Exit and log a message
# pre: exit_status: Integer exit status to exit with
#                   0 wiil be used if parameter is omitted
#      message: Message to log when exiting. May be omitted
# post: If exit_status is non-zero or $DEBUG>2 then
#       message logged.
#       Programme exits with exit_status
# return: does not return

sub ld_exit
{
	my ($exit_status, $message)=(@_);
	unless(defined($exit_status)) { $exit_status=0; }
	unless(defined($exit_status)) { $message=""; }

	if ($exit_status!=0 or $DEBUG>2) {
		&ld_log("Exiting with exit_status $exit_status: $message");
	}
	exit($exit_status);
}


# ld_open_socket
# Open a socket connection
# pre: remote: IP address as a dotted quad of remote host to connect to
#      port: port to connect to
#      protocol: Prococol to use. Should be either "tcp" or "udp"
# post: A Socket connection is opened to the remote host
# return: Open socket
#         Programe dies on error (may be caught by calling function)

sub ld_open_socket
{
	my ($remote, $port, $protocol) = @_;
	my ($iaddr, $paddr, $pro, $result);

	$iaddr = inet_aton($remote) || die "no host: $remote";
	$paddr = sockaddr_in($port, $iaddr);
	$pro = getprotobyname($protocol);
	socket(SOCK, PF_INET, SOCK_STREAM, $pro) || die "socket: $!";
	$result = connect(SOCK, $paddr);
	close(SOCK) || die "close: $!" if ($result);
	return $result;
}


# daemon
# Close and fork to become a daemon.
#
# Notes from unix programmer faq
# http://www.landfield.com/faqs/unix-faq/programmer/faq/
#
# Almost none of this is necessary (or advisable) if your daemon is being
# started by `inetd'.  In that case, stdin, stdout and stderr are all set up
# for you to refer to the network connection, and the `fork()'s and session
# manipulation should *not* be done (to avoid confusing `inetd').  Only the
# `chdir()' step remains useful.
#
# Gratuitously over documented, because it can be
#
# Writen by Horms, horms@verge.net.au for an unrelated project while
# working for Zip World, http://www.zipworld.com.au/, 1997-1999.

sub ld_daemon
{
	# `fork()' so the parent can exit, this returns control to the command
	# line or shell invoking your program.  This step is required so that
	# the new process is guaranteed not to be a process group leader. The
	# next step, `setsid()', fails if you're a process group leader.
	&ld_daemon_become_child();

	# setsid()' to become a process group and session group leader. Since a
	# controlling terminal is associated with a session, and this new
	# session has not yet acquired a controlling terminal our process now
	# has no controlling terminal, which is a Good Thing for daemons.
	if(POSIX::setsid()<0){
		&ld_exit(-1, "ld_daemon: Could not setsid");
	}

	# fork()' again so the parent, (the session group leader), can exit.
	# This means that we, as a non-session group leader, can never regain a
	# controlling terminal.
	&ld_daemon_become_child();

	# `chdir("/")' to ensure that our process doesn't keep any directory in
	# use. Failure to do this could make it so that an administrator
	# couldn't unmount a filesystem, because it was our current directory.
	if(chdir("/")<0){
		&ld_exit(-1, "ld_daemon: Could not chdir");
	}

	# `close()' fds 0, 1, and 2. This releases the standard in, out, and
	# error we inherited from our parent process. We have no way of knowing
	# where these fds might have been redirected to. Note that many daemons
	# use `sysconf()' to determine the limit `_SC_OPEN_MAX'.  `_SC_OPEN_MAX'
	# tells you the maximun open files/process. Then in a loop, the daemon
	# can close all possible file descriptors. You have to decide if you
	# need to do this or not.  If you think that there might be
	# file-descriptors open you should close them, since there's a limit on
	# number of concurrent file descriptors.
	close(STDIN);
	close(STDOUT);
	close(STDERR);

	# Establish new open descriptors for stdin, stdout and stderr. Even if
	# you don't plan to use them, it is still a good idea to have them open.
	# The precise handling of these is a matter of taste; if you have a
	# logfile, for example, you might wish to open it as stdout or stderr,
	# and open `/dev/null' as stdin; alternatively, you could open
	# `/dev/console' as stderr and/or stdout, and `/dev/null' as stdin, or
	# any other combination that makes sense for your particular daemon.
	if(open(STDIN, "</dev/null")<0){
		&ld_exit(-1, "ld_daemon: Could not open /dev/null");
	}
	if(open(STDOUT, ">>/dev/console")<0){
		&ld_exit(-1, "ld_daemon: Could not open /dev/console");
	}
	if(open(STDERR, ">>/dev/console")<0){
		&ld_exit(-1, "ld_daemon: Could not open /dev/console");
	}
}


# ld_daemon_become_child
# Fork, kill parent and return child process
# pre: none
# post: process forkes and parent exits
#       All preocess exit with exit status -1 if an error occurs
# return: parent: exits
#         child: none  (this is the process that returns)
# Written by Horms, horms@verge.net.au for an unrelated project while
# working for Zip World, http://www.zipworld.com.au/, 1997-1999.

sub ld_daemon_become_child
{
	my($status);

	$status = fork();

	if ($status<0){
		&ld_exit(-1, "ld_daemon_become_child: Could not fork: $!");
	}
	if ($status>0){
		&ld_exit(0, 
			"ld_daemon_become_child: Parent exiting as it should");
	}
}


# ld_gethostbyname
# Wrapper to gethostbyname. Look up the/an IP address of a hostname 
# If an IP address is given is it returned
# pre: name: Hostname of IP address to lookup
# post: gethostbyname is called to find an IP address for $name
#       This is converted to a string
# return: IP address
#         undef on error

sub ld_gethostbyname 
{
	my ($name)=(@_);

	my @host=gethostbyname($name);

	return((@host and defined($host[4]))?inet_ntoa($host[4]):undef);
}


# ld_getservbyname
# Wraper for getservbyname. Look up the port for a service name
# If a port is given it is returned.
# pre: name: Port or Service name to look up
# post: if $name is a number 
#         if 0<=$name<=65536 $name is returned
#         else undef is returned
#       else getservbyname is called to look up the port for the service
# return: Port
#         undef on error

sub ld_getservbyname 
{
	my ($name, $protocol)=(@_);

	if($name=~/^[0-9]+$/){ 
		return(($name>=0 and $name<65536)?$name:undef);
  	}

	my @serv=getservbyname($name, $protocol);

	return((@serv and defined($serv[2]))?$serv[2]:undef);
}


# ld_getservhostbyname
# Wraper for ld_gethostbyname and ld_getservbyname. Given a server of the
# form ip_address|hostname[:port|servicename] return ip_address[:port]
# pre: hostserv: Servver of the form ip_address|hostname[:port|servicename]
#      protocol: Protocol for service. Should be either "tcp" or "udp"
# post: lookups performed as per ld_getservbyname and ld_gethostbyname
# return: ip_address[:port]
#         undef on error

sub ld_gethostservbyname{
	my ($hostserv, $protocol) = (@_);

	my $ip;
	my $port;

	$hostserv =~ 
		/(\d+\.\d+\.\d+\.\d+|[A-Za-z0-9.-]+)(:(\d+|[A-Za-x0-9-]+))?/ 
		or return(undef);
	$ip=$1;
	$port=$3;

	$ip=&ld_gethostbyname($ip)  or return(undef);

	if(defined($port)){
	    $port=&ld_getservbyname($port, $protocol);
		if (defined($port)) {
		    return("$ip:$port");
		} else {
		    return(undef);
		}
	}
	return($ip);
}
