#!/usr/bin/perl
my($VERSION)=(qw$Id: ldirectord,v 1.77.2.51 2006/07/06 04:52:09 horms Exp $)[2];

######################################################################
# ldirectord                 http://www.vergenet.net/linux/ldirectord/
# Linux Director Daemon - run "perldoc ldirectord" for details
#
# 1999-2006 (C) Jacob Rief <jacob.rief@tiscover.com>,
#               Horms <horms@verge.net.au> and others
#
# License:      GNU General Public License (GPL)
#
# Note: * The original author of this software was Jacob Rief circa 1999
#       * It was maintained by Jacob Rief and Horms 
#         from November 1999 to July 2003.
#       * From July 2003 Horms is the maintainer
#
# 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., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
#
######################################################################

=head1 NAME

ldirectord - Linux Director Daemon

Daemon to monitor remote services and control Linux Virtual Server


=head1 SYNOPSIS

B<ldirectord> [B<-d|--debug>] [--] [I<configfile>] 
B<start>|B<stop>|B<restart>|B<reload>|B<status>

B<ldirectord> [B<-h|-?|--help|-v|--version>]

=head1 DESCRIPTION

B<ldirectord> is a daemon to monitor and administer real servers in a
cluster of load balanced virtual servers. B<ldirectord> typically is
started from heartbeat but can also be run from the command line. On
startup B<ldirectord> 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<ldirectord> can be started for each configuration, but more instances of
B<ldirectord> may be started for different configurations. This helps to
group clusters of services.  Normally one would put an entry inside
B</etc/ha.d/haresources>

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

to start ldirectord 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|--debug> Don't start as daemon and log verbosly. 

B<-h|--help> Print user manual and exit.

B<-v|--version> Print version and exit.

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)|firewall-mark>

Defines a virtual service by IP-address (or hostname) and port (or
servicename) or firewall-mark.  A firewall-mark is an integer greater than
zero. The configuration of marking packets is controled using the C<-m>
option to B<ipchains>(8).  All real services and flags for a virtual
service must follow this line immediately and be indented.

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<connecttimeout = >I<n>

Not used.

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<checkcount = >I<n>

The number of times a check will be attmpted before it is considered
to have failed. Only works with ping checks. Note that the
checktimeout is additive, so if checkcount is 3 and checktimeout is 2
seconds, then a total of 6 seconds worth of timeout will occur becore
the check fails. Default is 1.

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

Defines if <ldirectord> 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<ldirectord> 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<ldirectord> 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|sercvicename]> [B<gate>|B<masq>|B<ipip>]

the server onto which a webservice 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 overide the global fallback server, if set.


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/ldirectord.log>.


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

Use this directive to start an instance of ldirectord 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<ldirectord> 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 failback servers are determined
to be down, they are not actually removed from the kernel's LVS
table. Rather, their weight is set to zero which means that no
new connections will be accepted. This has the side effect,
that if the real server has persistent connections, new connections
from any existing clients will continue to be routed to the real
server, until the persistant timeout can expire. See
L<ipvsadm> for more information on persistant connections.

If I<no>, then the real or failback 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 overide 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<gate>|B<masq>|B<ipip> [I<weight>] [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, this is
intended primarily for fwmark services where the port for real servers is
ignored. 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, must be B<gate>, B<ipip> or B<masq>.  The thrid argument is
optional and defines the weight for that real server. 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.

=head2 More than one of these entries may be inside a virtual section.
The quiescent and fallback options listed above may also appear inside
a virtual section, in which case the global setting is overridden.

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

Type of check to perform. Negotiate sends a request and matches a receive
string. Connect only attemts 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 intervalls a negotiating check is done. Ping
means that ICMP ping will be used to test the availability of real servers.
Ping is also used as the connect check for UDP services. Off means no
checking will take place and no real or fallback servers will be activated.
On means no checking will take place and real servers will always be
activated. Default is I<negotiate>.

B<service = ftp>|B<smtp>|B<http>|B<pop>|B<pops>|B<nntp>|B<imap>|B<imaps>|B<ldap>|B<https>|B<dns>|B<mysql>|B<pgsql>|B<sip>|B<none>

The type of service to monitor when using checktype=negotiate. None denotes
a service that will not be monitored. If the port specfied for the virtual
server is 21, 25, 53, 80, 110, 119, 143, 389, 443, 3306, 5432 or 5060 then
the default is B<ftp>, B<smtp>, B<dns>, B<http>, B<pop>, B<pops>, B<nntp>,
B<imap>, <B<imaps>, B<ldap>, B<https>, B<mysql>, B<pgsql> or B<sip> 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.

For a MySQL or PostgeSQL checks, this should be a SQL query.
The data returned is not checked, only that the
answer is one or more rows.  This is a required setting.

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 litterals. 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.

For a MySQL check, the receive setting is not used.

B<httpmethod = GET>|B<HEAD>

Sets the HTTP method which should be used to fetch the URI specified in
the request-string. GET is the method used by default if the parameter is
not set. If HEAD is used, the receive-string should be unset.

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, IMAP, LDAP, MySQL, POP, PostgreSQL
and SIP servers.

=over 4

=item * For FTP, the default is anonymous.

=item * For a MySQL and PostgreSQL, the username must be provided.  

=item * For SIP the username is used as both the to and from address
	for an OPTIONS query. If unset it defaults to
	ldirectord\@<hostname>, hostname is derived as per the passwd
	option below.

=item * For all other services, the default is the empty string, in which
	case authentication will not be attempted.

=back 4

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

Password to use to login to FTP, IMAP, LDAP, MySQL, POP, PostgreSQL
and SIP servers.

=over 4

=item * The default is for FTP is ldirectord\@<hostname>,
	where hostname is the environment variable HOSTNAME evaluated at
	run time, or sourced from uname if unset.

=item * The default for all other services is an empty password.
	In the case of LDAP, MySQL and PostgreSQL this means
	that authentication will not be performed.

=back 4

B<database = ">I<databasename>B<">

Database to use for MySQL and PostgreSQL servers, this is the database that
the query (set by B<receive> above) will be performed against.  This is a
required setting.


B<scheduler => I<scheduler_name>

Scheduler to be used by LVS for loadbalancing. Default is "wrr".
For an information on the available sehedulers please see
the ipvsadm(8) man page.

B<persistent => I<n>

Number of seconds for persistent client connections.

B<netmask => I<w.x.y.z>

Netmask to be used for granularity of persistent client connections.

B<protocol = tcp>|B<udp>|B<fwm>

Protocol to be used. If the virtual is specified as an IP address and port
then it must be one of tcp or udp and will default to tcp. If a firewall
mark then the protocol must be fwm, which is the default.

B<emailalert = ">I<emailaddress>B<">

A valid email address for sending alerts about the changed connection status
to any real server defined in the virtual service.  This option requires
perl module MailTools to be installed.  Automatically tries to send email
using any of the built-in methods. See perldoc Mail::Mailer for more info on
methods.

B<emailalertfreq => I<n>

Delay in seconds between repeating email alerts while any given real server
in the virtual service remains inaccessible.  A setting of zero seconds will
inhibit the repeating alerts.  Default setting is zero.  The email timing
accuracy of this setting is dependent on the number of seconds defined in
the checkinterval configuration option.

=head1 FILES

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

B</var/log/ldirectord.log>

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

B</etc/services>

=head1 SEE ALSO

L<ipvsadm>, L<heartbeat>

Ldirectord Web Page: http://www.vergenet.net/linux/ldirectord/


=head1 AUTHORS

Horms <horms@verge.net.au>

Jacob Rief <jacob.rief@tiscover.com>

=cut

use strict;
use vars qw(
	    $AUTOCHECK
	    $CHECKINTERVAL
	    $CONNECTTIMEOUT
	    $LDIRECTORD
	    $LDIRLOG
	    $LD_TERM_CALLED
	    $NEGOTIATETIMEOUT
	    $RUNPID
	    $CHECKTIMEOUT
	    $QUIESCENT

	    $CALLBACK
	    $CFGNAME
	    $CMD
	    $CONFIG
	    $DEBUG
	    $FALLBACK
	    $SUPERVISED
	    $IPVSADM
	    $checksum
	    $initializing
	    $opt_d
	    $opt_h
	    $pid
	    $stattime
	    %LD_INSTANCE
	    @OLDVIRTUAL
	    @REAL
	    @VIRTUAL
	    $HOSTNAME
	    @EMAILSTATUS
	    @OLDEMAILSTATUS

	    $CRLF
);

# default values
$AUTOCHECK        = "no";
$CHECKINTERVAL    = 10;
$CHECKTIMEOUT     = 5;
$CONNECTTIMEOUT   = 0;
$LDIRECTORD       = ld_find_cmd("ldirectord", 1);
if (! defined $LDIRECTORD) {
	$LDIRECTORD = "/usr/sbin/ldirectord";
}
$LDIRLOG          = "/var/log/ldirectord.log";
$LD_TERM_CALLED   = 0;
$NEGOTIATETIMEOUT = 0;
$RUNPID           = "/var/run/ldirectord";
$QUIESCENT        = "yes";

$CRLF = "\x0d\x0a";

use Getopt::Long;
use Pod::Usage;
#use English;
#use Time::HiRes qw( gettimeofday tv_interval );
use Socket;
use Sys::Hostname;
use POSIX qw(setsid);
use Sys::Syslog qw(:DEFAULT setlogsock);

# command line options
my @OLD_ARGV = @ARGV;
my $opt_d = '';
my $opt_h = '';
my $opt_v = '';
Getopt::Long::Configure ("bundling", "no_auto_abbrev", "require_order");
GetOptions("debug|d" => \$opt_d, 
	   "help|h|?" => \$opt_h,
	   "version|v" => \$opt_v) or usage();

# main code
if ($opt_h) {
	exec_wrapper("/usr/bin/perldoc -U $LDIRECTORD");
	&ld_exit(127, "Exec failed");
}
if ($opt_v) {
	print("ldirectord  version $VERSION\n" .
	      "1999-2006 Jacob Rief, Horms and others\n" .
	      "<http://www.vergenet.net/linux/ldirectord/>\n".
	      "\n" .
	      "ldirectord comes with ABSOLUTELY NO WARRANTY.\n" .
	      "This is free software, and you are welcome to redistribute it\n".
	      "under certain conditions. " .
		      "See the GNU General Public Licence for details.\n");

	&ld_exit(0, "");
}

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

# 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", %LD_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)
	#require Net::LDAP;
        $SIG{'INT'} = \&ld_handler_term;
        $SIG{'QUIT'} = \&ld_handler_term;
        $SIG{'ILL'} = \&ld_handler_term;
        $SIG{'ABRT'} = \&ld_handler_term;
        $SIG{'FPE'} = \&ld_handler_term;
        $SIG{'SEGV'} = \&ld_handler_term;
        $SIG{'TERM'} = \&ld_handler_term;

        $SIG{'BUS'} = \&ld_handler_term;
        $SIG{'SYS'} = \&ld_handler_term;
        $SIG{'XCPU'} = \&ld_handler_term;
        $SIG{'XFSZ'} = \&ld_handler_term;

        $SIG{'IOT'} = \&ld_handler_term;
        $SIG{'ENT'} = \&ld_handler_term;


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

	if (defined $ENV{HOSTNAME}) {
		$HOSTNAME = "$ENV{HOSTNAME}";
	}
	else {
		use POSIX "uname";
		my ($s, $n, $r, $v, $m) = uname;
		$HOSTNAME = $n;
	}

	# search for the correct configuration file
	if ( !defined $ARGV[0] ) {
		usage();
	}
	if ( defined $ARGV[0] && defined $ARGV[1] ) {
		$CONFIG = $ARGV[0];
		if ($CONFIG =~ /([^\/]+)$/) {
			$CFGNAME = $1;
		}
		$CMD = $ARGV[1];
	} elsif ( defined $ARGV[0] ) {
		$CONFIG = "ldirectord.cf";
		$CFGNAME = "ldirectord";
		$CMD = $ARGV[0];
	}
	if ( $CMD ne "start" and $CMD ne "stop" and $CMD ne "status" 
			and $CMD ne "restart" and $CMD ne "try-restart"
			and $CMD ne "reload" and $CMD ne "force-reload") {
		usage();
	}
	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");
	}
	read_config();
	undef @OLDVIRTUAL;

	{
		my $log_str = "Invoking ldirectord invoked as: $0 ";
		for my $i (@ARGV) {
			$log_str .= $i . " ";
		}
		ld_log($log_str);
	}

	my $oldpid;
	my $filepid;
	if (open(FILE, "<$RUNPID.$CFGNAME.pid")) {
		$_ = <FILE>;
		chomp;
		$filepid = $_;
		close(FILE);
		# Check to make sure this isn't a stale pid file
		if (open(FILE, "</proc/$filepid/cmdline")) {
			$_ = <FILE>;
			if (/ldirectord/) {
				$oldpid = $filepid;
			}
			close(FILE);
		}
	}
	if (defined $oldpid) {
		if ($CMD eq "start") {
			ld_exit(0, "Exiting from ldirectord $CMD");
		} elsif ($CMD eq "stop") {
			kill 15, $oldpid;
			ld_exit(0, "Exiting from ldirectord $CMD");
		} elsif ($CMD eq "restart" or $CMD eq "try-restart") {
			kill 15, $oldpid;
			while (-f "$RUNPID.$CFGNAME.pid") {
				# wait until old pid file is removed
				sleep 1;
			}
			# N.B Fall through 
		} elsif ($CMD eq "reload" or $CMD eq "force-reload") {
			kill 1, $oldpid;
			ld_exit(0, "Exiting from ldirectord $CMD");
		} else { # status
			print STDERR "ldirectord for $CONFIG is running with pid: $oldpid\n";
			ld_cmd_children("status", %LD_INSTANCE);
			ld_log("ldirectord for $CONFIG is running with pid: $oldpid");
			ld_log("Exiting from ldirectord $CMD");
			ld_exit(0, "Exiting from ldirectord $CMD");
		}
	} else {
		if ($CMD eq "start" or $CMD eq "restart") {
			;
		} elsif ($CMD eq "stop" or $CMD eq "try-restart") {
			ld_exit(0, "Exiting from ldirectord $CMD");
		} elsif ($CMD eq "status") {
			my $status;
			if (defined $filepid) {
				print STDERR "ldirectord stale pid file " .
					"$RUNPID.$CFGNAME.pid for $CONFIG\n";
				ld_log("ldirectord stale pid file " .
					"$RUNPID.$CFGNAME.pid for $CONFIG");
				$status = 1;
			} else {
				$status = 3;
			}
			print STDERR "ldirectord is stopped for $CONFIG\n";
			ld_log("ldirectord is stopped for $CONFIG");
			ld_exit($status, "Exiting from ldirectord $CMD");
		} else {
			ld_log("ldirectord is stopped for $CONFIG");
			ld_exit(1, "Exiting from ldirectord $CMD");
		}
	}

	# Run as daemon
	if ($SUPERVISED || $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 usage
{
	pod2usage(-input => $LDIRECTORD, -exitval => -1);
}

sub init_error
{
	my $msg = shift;
	chomp($msg);
	&ld_log("$msg");
	unless ($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) = (@_);
	if ($LD_TERM_CALLED){
		$SIG{'__DIE__'} = "IGNORE";
		$SIG{"$signal"} = "IGNORE";
		die("Exit Handler Repeatedly Called\n");
	}
	$LD_TERM_CALLED = 1;

	ld_cmd_children("stop", %LD_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 = %LD_INSTANCE;
	eval {
		&read_config();
		my %NEW_INSTANCE = %LD_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("$LDIRECTORD $child reload")) {
					system("$LDIRECTORD $child start");
				}
			}
		}
		&ld_cmd_children("stop", %OLD_INSTANCE);
		&ld_cmd_children("start", %NEW_INSTANCE);
	};
	if ($@) {
		@VIRTUAL = @OLDVIRTUAL;
		%LD_INSTANCE = %OLD_INSTANCE;
	}
	undef @OLDVIRTUAL;
}


sub read_config
{
	undef @VIRTUAL;
	undef @REAL;
	undef $CALLBACK;
	undef %LD_INSTANCE;
	undef $checksum;
	$SUPERVISED = 0;
	$stattime = 0;
	my %virtual_seen;
	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;
			my $fwm = undef;
			my $virtual_id;
			my $virtual_line = $line;
			my $fallback_line;
			my @rsrv_todo;
			if ($vattr =~ /^(\d+\.\d+\.\d+\.\d+):([0-9A-Za-z]+)/) {
				$virtual_id = $ip_port = "$1:$2";
			} elsif ($vattr =~ /^([0-9A-Za-z._+-]+):([0-9A-Za-z]+)/) {
				$virtual_id = $ip_port = "$1:$2";
			} elsif ($vattr =~ /^(\d+)/){
				$virtual_id = $fwm = $1;
			} else {
				&config_error($line, 
					"invalid address for virtual server");
			}

			my (%vsrv, @rsrv);
			if ($ip_port) {
				$vsrv{checktype} = "negotiate";
			        $vsrv{protocol} = "tcp";
				if ($ip_port =~ /:53$/) {
					$vsrv{protocol} = "udp";
				}
			} else {
			        $vsrv{fwm} = $fwm;
				$vsrv{checktype} = "negotiate";
			        $vsrv{protocol} = "fwm";
				$vsrv{service} = "none";
				$vsrv{port} = "0";
			}
			$vsrv{real} = \@rsrv;
			$vsrv{scheduler} = "wrr";
			$vsrv{request} = "/";
			$vsrv{receive} = "";
			$vsrv{login} = "";
			$vsrv{passwd} = "";
			$vsrv{database} = "";
			$vsrv{checktimeout} = 0;
			$vsrv{connecttimeout} = 0;
			$vsrv{checkcount} = 1;
			$vsrv{negotiatetimeout} = 0;
			$vsrv{num_connects} = 0;
			$vsrv{httpmethod} = "GET";
			$vsrv{emailalert} = "";
			$vsrv{emailalertfreq} = 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 "ping" || $1 eq "off" || $1 eq "on") ) {
						$vsrv{checktype} = $1;
					} else {
						&config_error($line, "checktype must be connect, negotiate, ping, off, on or a positive number");
					}
				} elsif ($rcmd =~ /^checktimeout\s*=\s*(.*)/){
                                        $1 =~ /(\d+)/ && $1 or &config_error($line, "invalid check timeout");
                                        $vsrv{checktimeout} = $1;
				} 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 check timeout");
                                        $vsrv{negotiatetimeout} = $1;
				} elsif ($rcmd =~ /^checkcount\s*=\s*(.*)/){
                                        $1 =~ /(\d+)/ && $1 or &config_error($line, "invalid check count");
                                        $vsrv{checkcount} = $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;
				} elsif ($rcmd =~ /^database\s*=\s*\"(.*)\"/) {
					$1 =~ /(.+)/ or &config_error($line, "invalid database");
					$vsrv{database} = $1;
				} 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*(.*)/) {
					# Intentonally ommit checking the
					# scheduler against a list of know
					# schedulers. This is because from
					# time to time new shedulers are
					# added. But ldirectord is
					# maintained distributed
					# independantly of this. Thus
					# ldirectord needs to be manually
					# updated/upgraded.  So just accept
					# any schedluer that matches
					# [a-z]+. I.e. is syntactically
					# correct (all schedulers so far
					# match that pattern). Ipvsadm will
					# report an error is a sheduler
					# isn't available / doesn't exist.
					$1 =~ /([a-z]+)/ 
					    or &config_error($line, "invalid scheduler, should be only lowercase letters (a-z)");
					$vsrv{scheduler} = $1;
				} 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);
					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");
					}
				} 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 "pops" || $1 eq "imap" || $1 eq "imaps" || $1 eq "nntp" || $1 eq "dns" || $1 eq "mysql" || $1 eq "pgsql" || $1 eq "sip")
					    or &config_error($line, "service must be http, https, ftp, smtp, pop, pops, imap, imaps, ldap, nntp, dns, mysql, pgsql, sip, or none");
					$vsrv{service} = $1;
					if($vsrv{service} eq "ftp" and 
							$vsrv{login} eq "") {
						$vsrv{login} = "anonymous";
					}
					elsif($vsrv{service} eq "sip" and 
							$vsrv{login} eq "") {
						$vsrv{login} = "ldirectord\@$HOSTNAME";
					}
					if($vsrv{service} eq "ftp" and 
							$vsrv{passwd} eq "") {
						$vsrv{passwd} = "ldirectord\@$HOSTNAME";
					}
				} elsif ($rcmd =~ /^httpmethod\s*=\s*(.*)/) {
					$1 =~ /(\w+)/ && (uc($1) eq "GET" || uc($1) eq "HEAD")
					    or &config_error($line, "httpmethod must be GET or HEAD");
					$vsrv{httpmethod} = uc($1);
				} 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;
				} elsif  ($rcmd =~ /^emailalert\s*=\s*(.*)/) {
					$1 =~ /(.+)/ or &config_error($line, "no email address specified");
					$vsrv{emailalert} = $1;
				} elsif  ($rcmd =~ /^emailalertfreq\s*=\s*(\d*)/) {
					$1 =~ /(\d+)/ or &config_error($line, "invalid email alert frequency");
					$vsrv{emailalertfreq} = $1;
				} 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);

			# Check for duplicate now we have all the
			# information to generate the id
			$virtual_id = get_virtual_id_str(\%vsrv);
			if (defined $virtual_seen{$virtual_id}) {
				&config_error($line, 
					"duplicate virtual server");
			}
			$virtual_seen{$virtual_id} = 1;

			#Arggh a goto :(
			goto outer_loop;
		}
		next if ($_ =~ /^\s*$/ || $_ =~ /^\s*#/);
		if ($_ =~ /^checktimeout\s*=\s*(.*)/) {
			($1 =~ /(\d+)/ && $1 && $1>0) or &config_error($line, 
					"invalid timeout value");
			$CHECKTIMEOUT = $1;
		} 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 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");
			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)) {
			        $tcp_fb=&parse_fallback($line, $tcp);
                        }
                        if(defined($udp)) {
			        $udp_fb=&parse_fallback($line, $udp);
                        }
			$FALLBACK = { "tcp" => $tcp_fb, "udp" => $udp_fb };
		} elsif ($_ =~ /^autoreload\s*=\s*(.*)/) {
			($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 $tmpLDIRLOG = $LDIRLOG;
			$LDIRLOG = $1;
			if (&ld_openlog()) {
				$LDIRLOG = $tmpLDIRLOG;
				&config_error($line, 
						"unable to open logfile: $1");
			}
		} elsif ($_ =~ /^execute\s*=\s*(.*)/) {
			$LD_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 {
			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", "pops", "imap", "imaps", "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 "995") {
                                $vsrv->{service} = "pops";
                        }
			elsif ($vsrv->{port} eq "119") {
				$vsrv->{service} = "nntp";
			} 
			elsif ($vsrv->{port} eq "143") {
				$vsrv->{service} = "imap";
			} 
			elsif ($vsrv->{port} eq "993") {
				$vsrv->{service} = "imaps";
			}
			elsif ($vsrv->{port} eq "389") {
				$vsrv->{service} = "ldap";
			}
			elsif ($vsrv->{port} eq "53") {
				$vsrv->{service} = "dns";
			} 
			elsif ($vsrv->{port} eq "3306") {
				$vsrv->{service} = "mysql";
			} 
			elsif ($vsrv->{port} eq "5432") {
				$vsrv->{service} = "pgsql";
			} 
			elsif ($vsrv->{port} eq "5060") {
				$vsrv->{service} = "sip";
			} 
			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
#             gate|masq|ipip [<weight>] [">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
#             gate|masq|ipip [<weight>] [">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};

	$flags =~ /(\w+)(.*)/ && ($1 eq "gate" || $1 eq "masq" || $1 eq "ipip")
	    or &config_error($line, 
	    	"forward method must be gate, masq or ipip");

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

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

	if(defined($flags) and $flags =~ /\s+(\d+)(.*)/) {
		$new_rsrv->{"weight"} = $1;
		$flags = $2;
	}

	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] [gate|masq|ipip]
# 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;


        if($fwd) {
                ($fwd eq "gate" || $fwd eq "masq" || $fwd eq "ipip")
	        or &config_error($line, 
	    	        "forward method must be gate, masq or ipip");
        }
        else {
          $fwd="gate"
        }

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


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

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

	if ($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";
		} elsif ($$v{protocol} eq "udp") {
			$$v{proto} = "-u";
		} elsif ($$v{protocol} eq "fwm") {
			$$v{proto} = "-f";
		}
		$$v{flags} = "$$v{proto} " .  &get_virtual($v) . " ";
		$$v{flags} .= "-s $$v{scheduler} " if defined ($$v{scheduler});
		if (defined $$v{persistent}) {
			$$v{flags} .= "-p $$v{persistent} ";
			$$v{flags} .= "-M $$v{netmask} " if defined ($$v{netmask});
		}
		my $real = $$v{real};
		for my $r (@$real) {
                        $$r{forw} = get_forward_flag($$r{forward});
			if (defined $$r{weight}) {
				 $$r{wght} = "$$r{weight}";
			} else {
				 $$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);
		$$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);
	}
}


# ld_read_ipvsadm
# Parses the output of "ipvsadm -L -n" and puts into a structure of
# the following from:
# 
# {
#   (vip_address:vport|fwmark) protocol => {
#     "scheduler" => scheduler,
#     "persistent" => timeout,     # May be omitted
#     "netmask" => netmask,        # May be omitted
#     "real" => {
#       rip_address:rport => {
#         "forward" => forwarding_mechanism,
#         "weight"  => weight
#       },
#       ...
#     }
#   },
#   ...
# }
# 
# where: 
#   vip_address: IP address of virtual service
#   vport: Port of virtual service
#   fwmark: Firewall Mark of virtual service
#   scheduler: Scheduler for virtual service
#   timeout: Timeout for persistancy. Omitted if service is not persistant.
#   nemask: Netmask for persistancy. Omitted if service is not persistant.
#
#   rip_address: IP address of real server
#   rport: Port of real server
#   forwarding_mechanism: Forwarding mechanism for real server. 
#                         One of: gate, ipip, masq.
#   weight: Weight of real server
#
# pre: none
# post: ipvsadm -L -n is parsed
# result: reference to sructure detailed above.

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

	# read status of current ipvsadm -L -n
	unless(open(IPVS, "$IPVSADM -L -n |")){
          &ld_exit(1, "Could not run $IPVSADM -L -n: $!");
        }
	$_ = <IPVS>; $_ = <IPVS>; $_ = <IPVS>;

	while (<IPVS>) {
		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+)/) {
			$real_service = "$2 ".lc($1);
			$oldsrv{"$real_service"} = {"real"=>{}, "scheduler"=>$3};
		} else {
			next;
		}
		while(<IPVS>) {
			last unless $_ =~ / ->\s+(\d+\.\d+\.\d+\.\d+\:\d+)\s+(\w+)\s+(\d+)/;
			if ($2 eq "Route") {
				$fwd = "gate";
			} elsif ($2 eq "Tunnel") {
				$fwd = "ipip";
			} elsif ($2 eq "Masq") {
				$fwd = "masq";
			}
			$oldsrv{"$real_service"}->{"real"}->{"$1"} = {"forward"=>$fwd, "weight"=>$3};
		}
		redo;
	}
	close(IPVS);

        return(\%oldsrv);
}

sub ld_start
{
	my $oldsrv;
	my $real_service;
	my $nv;
	my $nr;
	my $server_down = {};

	undef @EMAILSTATUS;
	
	# read status of current ipvsadm -L -n
        $oldsrv=&ld_read_ipvsadm();

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

		if (exists($oldsrv->{"$real_service"})) {
			# service exists, modify it
			&system_wrapper("$IPVSADM -E $$nv{flags}");
			&ld_log("Changed virtual server: " . &get_virtual($nv));
		}
		else {
			# no such service, create a new one
			&system_wrapper("$IPVSADM -A $$nv{flags}");
			&ld_log("Added virtual server: " . &get_virtual($nv));
		}
	}

	# make sure real servers are up to date
	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}";
			my %emailstat;
			$emailstat{server}=$real_str . " " . $nv->{server} . ":" . $nv->{port};
			$emailstat{emailalertfreq}=$nv->{emailalertfreq};
			$emailstat{emailalert}=$nv->{emailalert};
			push(@EMAILSTATUS, \%emailstat);			
			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});
		}

		# remove remaining entries for real servers
		for my $k (keys %$or) {
			&system_wrapper("$IPVSADM -d " . $nv->{proto} .
					&get_virtual($nv) . " -r $k");
			&ld_log("Removed real server (start): $k (" . 
					#scalar(%{$nv->{real_status}}) .
					" x " .  &get_virtual($nv) . ")\n");
			delete($$or{$k});
		}

		delete($oldsrv->{&get_virtual($nv) . " " . $nv->{protocol}});
		&fallback_on($nv);
	}

	for my $k (keys (%$server_down)) {
	        my $v = $server_down->{$k};
		service_set(@$v[0], @$v[1], "down", "force");
		delete($server_down->{$k});
		#sleep 5;
	}

	# remove remaining entries for virtual servers
	foreach $nv (@OLDVIRTUAL) {
		if (! defined($oldsrv->{&get_virtual($nv) . " " . 
					$nv->{protocol}})) {
			next;
		}
		# service still exists, remove it
		&system_wrapper("$IPVSADM -D " . $nv->{proto} . " " . 
				&get_virtual($nv));
		&ld_log("Removed virtual server (start): " . 
				&get_virtual($nv) . "\n");
	}
}


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


sub ld_stop
{
	foreach my $v (@VIRTUAL) {
		my $real = $$v{real};
		foreach my $r (@$real) {
			if (defined $$r{virtual_status}) {
				&system_wrapper("$IPVSADM -d $$v{proto} " . &get_virtual($v) . " -r $$r{server}:$$r{port}");
				_status_down($v, $r);
				&ld_log("Removed real server (stop): " .
					"$$r{server}:$$r{port} (" .
					#scalar(%{$v->{real_status}}) . 
					" x " . &get_virtual($v) . ")" );
			}
		}
		&system_wrapper("$IPVSADM -D $$v{proto} " .  &get_virtual($v));
		&ld_log("Removed virtual server (stop): " .  &get_virtual($v));
	}
}


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

			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" || $$v{service} eq "https") {
						$$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 "pop") {
						$$r{num_connects} = 0 if (check_pop($v, $r));
					} elsif ($$v{service} eq "pops") {
						$$r{num_connects} = 0 if (check_pops($v, $r));
					} elsif ($$v{service} eq "imap") {
						$$r{num_connects} = 0 if (check_imap($v, $r));
					} elsif ($$v{service} eq "imaps") {
						$$r{num_connects} = 0 if (check_imaps($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));
					} elsif ($$v{service} eq "sip") {
						$$r{num_connects} = 0 if (check_sip($v, $r));
					} elsif ($$v{service} eq "mysql") {
						$$r{num_connects} = 0 if (check_mysql($v, $r));
					} elsif ($$v{service} eq "pgsql") {
						$$r{num_connects} = 0 if (check_pgsql($v, $r));
					} else {
						$$r{num_connects} = 0 if (check_none($v, $r));
					}
				} elsif ($$v{checktype} eq "connect") {
					if ($$v{protocol} ne "udp") {
						&ld_debug(2, "Checking connect: real server=$real_id (virtual=$virtual_id)");
						check_connect($v, $r);
					}
					else {
						&ld_debug(2, "Checking connect (ping): real server=$real_id (virtual=$virtual_id)");
						check_ping($v, $r);
					}
				} elsif ($$v{checktype} eq "ping") {
					&ld_debug(2, "Checking ping: real server=$real_id (virtual=$virtual_id)");
					check_ping($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;
		}
			
		my $currenttime=time();
		foreach my $es (@EMAILSTATUS){
			if (($es->{alerttime} > 0 ) && ($currenttime - $es->{alerttime} >= $es->{emailalertfreq})){
				&ld_emailalert("Inaccessible real server: $es->{server}", $es->{emailalert});
				&ld_set_email_status($es->{server}, $currenttime);
			}
		}
	}
}


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

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

	&ld_debug(2, "check_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("$$v{httpmethod}", "$$r{url}", $h);
	my $res;
	{
		# LWP makes ungaurded 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);
	}

	if ($$v{service} eq "https") {
		&ld_debug(2, "SSL-Cipher: " . 
			$res->header('Client-SSL-Cipher'));
		&ld_debug(2, "SSL-Cert-Subject: " . 
			$res->header('Client-SSL-Cert-Subject'));
		&ld_debug(2, "SSL-Cert-Issuer: " . 
			$res->header('Client-SSL-Cert-Issuer'));
	}

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

	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 Mail::POP3Client;
        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 Mail::POP3Client(USER => $$v{login},
                                        PASSWORD => $$v{passwd},
                                        HOST => $$r{server},
                                        USESSL => 0,
                                        PORT => $port,
                                        DEBUG => 0,
                                        TIMEOUT => $$v{negotiatetimeout});

        if (!$pop) {
                service_set($v, $r, "down");
                return 1;
        }

        if($$v{login} ne "") {
                my $authres = $pop->login();
                $pop->close();
                if (!$authres) {
                        service_set($v, $r, "down");
                        return 0;
                }
        }

        $pop->close();
        service_set($v, $r, "up");
        return 1;
}

sub check_pops
{
        require Mail::POP3Client;
        my ($v, $r) = @_;
        my $port=(defined $$v{checkport}?$$v{checkport}:$$r{port});

        &ld_debug(2, "Checking pops server=$$r{server} port=$port");

        my $pops = new Mail::POP3Client(USER => $$v{login},
                                        PASSWORD => $$v{passwd},
                                        HOST => $$r{server},
                                        USESSL => 1,
                                        PORT => $port,
                                        DEBUG => 0,
                                        TIMEOUT => $$v{negotiatetimeout});
        if (!$pops) {
                service_set($v, $r, "down");
                return 1;
        }

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


        $pops->close();
        service_set($v, $r, "up");
        return 0;
}

sub check_imap
{
        require Net::IMAP::Simple;
        my ($v, $r) = @_;
        my $port=(defined $$v{checkport}?$$v{checkport}:$$r{port});
        
        &ld_debug(2, "Checking imap server=$$r{server} port=$port");
        
        my $imap = Net::IMAP::Simple->new($$r{server},
                                        port => $port,
                                        timeout => $$v{negotiatetimeout});
        
        if (!$imap) {
                service_set($v, $r, "down");
                return 1;
        }
        
        if($$v{login} ne "") {
                my $authres = $imap->login($$v{login},$$v{passwd});
                $imap->quit;
                if (!$authres) {
                        service_set($v, $r, "down");
                        return 1;
                }
        }
        
        $imap->quit();
        service_set($v, $r, "up");
        return 0;
}

sub check_imaps
{
        require Net::IMAP::Simple::SSL;
        my ($v, $r) = @_;
        my $port=(defined $$v{checkport}?$$v{checkport}:$$r{port});

        &ld_debug(2, "Checking imaps server=$$r{server} port=$port");

        my $imaps = Net::IMAP::Simple::SSL->new($$r{server},
                                        port => $port,
                                        timeout => $$v{negotiatetimeout});
        if (!$imaps) {
                service_set($v, $r, "down");
                return 1;
        }

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

        $imaps->quit();
        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 1;
	}
		
	my $mesg;
	if ($$v{login} && $$v{passwd}) {
		$mesg = $ldap->bind($$v{login}, password=>$$v{passwd}) ;
	}
	else {
		$mesg = $ldap->bind ;
	}
	if ($mesg->is_error) {
		service_set($v, $r, "down");
		&ld_debug(4, "Bind failed");
		return 1;
	}

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

	&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 1;
        }
        $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");
			$status = 0;
                } else {
                        service_set($v, $r, "down");
                }
        }
        $s->remove($sock);
        $sock->close;

        return $status;
}

sub check_mysql
{
	return check_sql(@_, "mysql", "database");
}

sub check_pgsql
{
	return check_sql(@_, "Pg", "dbname");
}

sub check_sql
{
	require DBI;
	my ($v, $r, $dbd, $dbname) = @_;
	my $port=(defined $$v{checkport}?$$v{checkport}:$$r{port});
	my ($dbh, $sth, $query, $rows, $result);   # Local variables
	$query = $$r{request};
	$query =~ s#^/##;
	unless ($$v{login} && $query) {
		service_set($v, $r, "down");
		&ld_log("Error: Must specify a login and request string for mysql and postgresql checks. Not adding $$r{server}.\n");
		return 1;
	}
	$result=2;   # Set result flag.  Only ok if ends up at zero.
	&ld_debug(2, "Checking $$v{server} server=$$r{server} port=$port\n");
	$dbh = DBI->connect("dbi:$dbd:$dbname=$$v{database};host=$$r{server};port=$port", $$v{login}, $$v{passwd});
	unless ($dbh) {
		&ld_debug(4, "Failed to bind to $$r{server} with $dbh->err");
		service_set($v, $r, "down");
		return 1;
	}
	$result--;
	$sth = $dbh->prepare($query);
	$rows = $sth->execute;
	ld_debug(4, "Database search returned $rows rows");
	if ($rows gt 0) {
		# If it returns with a number, it is ok.
		# Disallows query of an empty table.
		$result--;
	}
	# If user defined a receive string (number of rows returned), only do
	# the check if the previous fetchall_arrayref succeeded.
	#if (defined $$r{receive} && $result eq 0) {
	#	# Receive string specifies an exact number of rows
	#	if ($rows ne $$r{receive}) {
	#	ld_debug(2,"Service down, receive=$$r{receive}");
	#		$result=1;
	#	}
	#}
	if ($result == 1) {
		# Should never get here
		service_set($v, $r, "down");
		return 1;
	}
	service_set($v, $r, "up");
	$sth->finish;
	$dbh->disconnect;
	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 $sock = &ld_open_socket($$r{server}, $port, $$v{protocol});
		if ($sock) {
			close($sock);
		} else {
			alarm 0; # Cancel the alarm
			die("Socket Connect Failed");
		}
		&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_sip
{
	my ($v, $r) = @_;
	my $sip_d_port=(defined $$v{checkport}?$$v{checkport}:$$r{port});

	&ld_debug(2, "Checking sip server=$$r{server} port=$sip_d_port");
	

	eval {
		use Socket;

		local $SIG{'__DIE__'} = "DEFAULT";
		local $SIG{'ALRM'} = sub { die "Timeout Alarm" };
		&ld_debug(4, "Timeout is $$v{checktimeout}");
		alarm $$v{checktimeout};

		my $sock = &ld_open_socket($$r{server}, $sip_d_port, 
					$$v{protocol});
		unless ($sock) {
			alarm 0;
			die("Socket Connect Failed");
		}

		my $sip_sockaddr = getsockname($sock);
		my ($sip_s_port, $sip_s_addr) = sockaddr_in($sip_sockaddr);
		my $sip_s_addr_str = inet_ntoa($sip_s_addr);

		&ld_debug(3, "Connected from $sip_s_addr_str:$sip_s_port to " .
			$$r{server} . ":$sip_d_port");

		select $sock;
		$|=1;
		select STDOUT;

		my $request = 
		"OPTIONS sip:" . $$v{login} . " SIP/2.0\r\n" .
		"Via: SIP/2.0/UDP $sip_s_addr_str:$sip_s_port;" .
			"branch=z9hG4bKhjhs8ass877\r\n" .
		"Max-Forwards: 70\r\n" .
		"To: <sip:" . $$v{login} . ">\r\n" .
		"From: <sip:" . $$v{login} . ">;tag=1928301774\r\n" .
		"Call-ID: a84b4c76e66710\r\n" .
		"CSeq: 63104 OPTIONS\r\n" .
		"Contact: <sip:" . $$v{login} . ">\r\n" .
		"Accept: application/sdp\r\n" .
		"Content-Length: 0\r\n\r\n";

		print "Request:\n$request";
		print $sock $request;

		my $ok;
		my $reply;
		while (<$sock>) {
			chomp;
			$/="\r";
	 		chomp;
			$/="\n";
	
			last if ($_ eq "");

			if (!defined $ok) {
				# Check status
				$ok = $_;
				if ($ok !~ m/^SIP\/2.0 200 OK/) {
					alarm 0; # Cancel the alarm
				       close($sock);
					die "$ok\n";
				}
				next;
			}
			$reply .= "$_\n";

			# Add more checks here as desired
		}
		alarm 0; # Cancel the alarm
		close($sock);

		if (!defined $ok) {
			die "No OK\n";
		}

		print "Reply:\n$ok\n$reply\n";
	};

	if ($@) {
		&service_set($v, $r, "down");
		&ld_debug(3, "Deactivated service $$r{server}:$$r{port}: $@");
		return 1;
	} else {
		&service_set($v, $r, "up");
		&ld_debug(3, "Activated service $$r{server}:$$r{port}");
		return 0;
	}
}


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(TMP,'+>', undef);

	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}", *TMP);
	$ftp->quit();

	seek TMP, 0, 0;
	local $/;
	$memory = <TMP>;
	close TMP;

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

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


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});
		 if ($$v{"protocol"} eq "tcp") {
		 	$res->usevc(1);
		 }
		 $query = $res->search($request);
		 alarm(0);
	};
 
	if (@$ eq "timeout\n" or ! $query) {
		 service_set($v,$r,"down");
		 return 1;
	}
 
	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 0;
		}
        }
 
	service_set($v,$r,"down");
	return 1;
}


sub check_ping 
{
	use Net::Ping;

	my ($v,$r) = (@_);

	&ld_debug(2, "Checking ping: " .  "host=\"" .  $$r{server} . 
		"\" checktimeout=\"" . $$v{"checktimeout"} .
		"\" checkcount=\"" . $$v{"checkcount"} . "\"\n");

	my $p = Net::Ping->new("icmp","1","64");
	for (my $attempt = 0; $attempt < $$v{"checkcount"}; $attempt++) {
		if ($p->ping($$r{server}, $$v{"checktimeout"})) {
    			&ld_debug(2, "pong from $$r{server}\n");
			service_set($v,$r,"up");
			return 0;
		}
  		&ld_debug(2, "ping to $$r{server} timed out " .
					"(attempt " .  ($attempt + 1) . "/" . 
					$$v{"checkcount"} . ")\n");
	}

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


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


# 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 ldirectord 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 quiecent 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 a tcp or
#                udp service. Of the form fwmark for a fwm service.
#      rforw: Forwarding mechanism of service. Sould be one of "-g" "-i" or
#             "-m"
#      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

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

        my $oldsrv;
        my $ov;
        my $or;
        my $ipvsadm_args;
        my $log_args;
	my $virtual_str;
	my $old_rservice;
	my $is_quiescent;

	$virtual_str = &get_virtual($v);

        $oldsrv=&ld_read_ipvsadm();
        $ov=$oldsrv->{$virtual_str . " " . $v->{"protocol"}};
	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";
	}

        $or=$ov->{"real"}->{$rservice};

	# If a virtual service is a IP/port service (not fwmark)
	# and a real-servers uses a forwarding mechanism other than masq
	# then the port will always be that of the virtual service.
	# This includes real-servers that LVS has set to use
	# the local forwarding mechanism because their IP address
	# is local. Thus, if $rservice does not exist test
	# for the same ip address with the virtual servers port.
	# N.B: This could cause strange things to happen if
	# there is a clash between two real servers on different ports
	# that LVS has mapped to being the same thing.
	if(!defined($or)) {
		$old_rservice = $rservice;
		$rservice =~ /(.*):(.*)/;
		$rservice = $1;
		$virtual_str =~ /(.*):(.*)/;
		$rservice .= ":" . $2;
        	$or=$ov->{"real"}->{$rservice};
		# If this doesn't exist either, use the original service.
		# Otherwise if masq and quescence is in use, the
		# real server is not local, and it has an alternate port to
		# the virtual server, using the mapped service will
		# result in a quiescent service being created on the
		# virtual server's port, which is not wanted.
		if(!defined($or)) {
			$rservice = $old_rservice;
			$old_rservice = undef;
		}
	}

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

	$ipvsadm_args = "$$v{proto} " . $virtual_str . " -r $rservice";
        $log_args = "$tag server: $rservice ";
	if(defined($old_rservice)) {
		$log_args .= "mapped from $old_rservice "
	}
	$log_args .= "(" #. scalar(%{$v->{real_status}}) 
		. " x $virtual_str)";

	my $currentserver=$rservice . " " . $virtual_str;
	my $currenttime=time();
	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)");
		}
		if(defined($$v{emailalert})) {
			&ld_emailalert("Quiescent $log_args (Weight set to 0)",$$v{emailalert});
			&ld_set_email_status($currentserver, $currenttime);
		}
        }
	else {
                &system_wrapper("$IPVSADM -d $ipvsadm_args");
	        &ld_log("Deleted $log_args");
	        if(defined($$v{emailalert})) {
			&ld_emailalert("Deleted $log_args",$$v{emailalert});
			&ld_set_email_status($currentserver, $currenttime);
		}
	}
}


# _restore_service
# Make a retore 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 ldirectord 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 a tcp or
#                udp service. Of the form fwmark for a fwm service.
#      rforw: Forwarding mechanism of service. Sould be one of "-g" "-i" or
#             "-m"
#      rwght: Weight of service. Sold 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

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

        my $oldsrv;
        my $ov;
        my $or;
        my $ipvsadm_args;
        my $log_args;

	$ipvsadm_args = "$$v{proto} " . &get_virtual($v) 
                        . " -r $rservice $rforw -w $rwght";
        $log_args = "$tag server: $rservice "
                    . "(" #. scalar(%{$v->{real_status}}) 
		    . " x " .  &get_virtual($v) . ")";

        #if the server exists then restore its weight
        # otherwise add the server
        $oldsrv=&ld_read_ipvsadm();
        $ov=$oldsrv->{&get_virtual($v) . " " . $v->{"protocol"}};
        if(defined($ov)){
                $or=$ov->{"real"}->{$rservice};
        }
        my $currentserver=$rservice . " " . $v->{server} . ":" . $v->{port};
        if(defined($or)){
                unless($or->{"weight"} eq $rwght and
                       get_forward_flag($or->{"forward"}) eq $rforw){
                        &system_wrapper("$IPVSADM -e $ipvsadm_args");
	                &ld_log("Restored $log_args (Weight set to $rwght)");
	                if(defined($$v{emailalert})) { 
				&ld_emailalert("Restored $log_args (Weight set to $rwght)",$$v{emailalert});
				&ld_set_email_status($currentserver, "0");
			}
                }
        }
        else {
                &system_wrapper("$IPVSADM -a $ipvsadm_args");
	        &ld_log("Added $log_args (Weight set to $rwght)");
		if(defined($$v{emailalert})) {
			&ld_emailalert("Added $log_args (Weight set to $rwght)",$$v{emailalert});
			&ld_set_email_status($currentserver, "0");
		}
        }
}


# 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 only 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 ldirectord 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 ldirectord 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)) {
		my $currenttime=time();
		foreach my $emailstats (@EMAILSTATUS) {
			my $currentserver=$r->{server} . ":" . $r->{port} . " " . $v->{server} . ":" . $v->{port};
			if ($currentserver eq $emailstats->{server}){
				if ($emailstats->{alertfreq} > 0){
					if ($currenttime - $emailstats->{alerttime} > $emailstats->{alertfreq}){
						&ld_log("email alert freq: " . $currentserver);
					}
				} 
			}
		}
		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 ($opt_d or $SUPERVISED) {
		# Instantly do nothing
		return(0);
	}	
	if( $LDIRLOG =~ /^\/(.*)/ ) {
	    # Open and close the file as a test.
	    # We open the file each time we want to log to it
	    unless (open(LOGFILE, ">>$LDIRLOG") and close(LOGFILE)) {
		return 1;
	    }
	}
	else
	{
	    # Assume LDIRLOG is a logfacility, log to syslog
	    setlogsock( "unix" );
	    openlog( "ldirectord", "pid", "$LDIRLOG" );
	}
	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 ($opt_d) {
		print STDERR "$message\n";
	} elsif ($SUPERVISED) {
		print "[$now] $message\n";
	} elsif ( $LDIRLOG =~ /^\/(.*)/ ) {
		unless (open(LOGFILE, ">>$LDIRLOG")
				and print LOGFILE "[$now|$CFGNAME|$$] $message\n"
				and close(LOGFILE)) {
			print STDERR "$message\n";
	    		return 1;
	    	}
	}
	else {
	    # Assume LDIRLOG is a logfacility, log to syslog
	    syslog( "info", "$message" );
	}
	return(0);
}

# ld_emailalert
# Send email alerts per virtual server
# pre: message: Message to email
# post: message is emailed if emailalert defined for virtualserver 
# return: 0 on success
#         1 on error
sub ld_emailalert
{
	my ($emailsubject,$emailto) = (@_);
	require Mail::Send;
	my $emailmsg;
	my $emailfh;
	               
	unless ($emailmsg = new Mail::Send Subject=>$emailsubject, To=>$emailto
			and $emailfh = $emailmsg->open
			and print $emailfh ""
			and $emailfh->close) {
		&ld_log("failed to send email message\n");
		return 1;
	}
	return(0);
}

# ld_set_email_status
# Change the alert time for the real server
# pre: real server and time setting
# post: EMAILSTATUS array is updated
# return: none
sub ld_set_email_status{
	my ($currentserver, $emailtime) = (@_);
	@OLDEMAILSTATUS = @EMAILSTATUS;
	undef @EMAILSTATUS;
	foreach my $es (@OLDEMAILSTATUS){
		my (%emailstats);
		$emailstats{server}=$es->{server};
		$emailstats{emailalertfreq}=$es->{emailalertfreq};
		$emailstats{emailalert}=$es->{emailalert};
		if ($currentserver eq $emailstats{server}){
			$emailstats{alerttime}=$emailtime;
		}else{
			$emailstats{alerttime}=$es->{alerttime};
		}
		push(@EMAILSTATUS, \%emailstats);
	}
	return;
}

# 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)
}


# 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) = (@_);

	if ($nv->{"protocol"} eq "fwm"){
		return $nv->{"fwm"};
	} else {
        	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 or udp
#      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 $virtualhost = "";
	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"};
	}

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

        $real    = $check . ":" . $v->{"protocol"} . ":" 
	         . $r->{"server"} . ":" . $r->{"port"} . ":" 
		 . $virtualhost . ":" . $checkport . ":" 
		 . $r->{"weight"} . ":"
		 . 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) = (@_);

	return $v->{"protocol"} . ":" .  &get_virtual($v);
}


# get_forward_flag
# Get the ipvsadm flag corresponging to a forwarding mechanism
# pre: forward: Name of forwarding mechanism. u
#               Should be one of ipip, masq or gate
# post: none
# return: ipvsadm 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");
	} 
        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($message)) { $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
#         undef on error

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

	$iaddr = inet_aton($remote) || die "no host: $remote";
	$paddr = sockaddr_in($port, $iaddr);
	$pro = getprotobyname($protocol);
	if ($protocol eq "udp") {
		socket(SOCK, PF_INET, SOCK_DGRAM, $pro) || die "socket: $!";
	}
	else {
		socket(SOCK, PF_INET, SOCK_STREAM, $pro) || die "socket: $!";
	}
	$result = connect(SOCK, $paddr);
	unless ($result) {
		return undef;
	}
	return *SOCK;
}


# 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.
    #
    # This code used to open /dev/console for STDOUT and STDERR,
    # but that was changed to /dev/null to stop the code hanging in
    # the case where /dev/console is unavailable for some reason
    # http://www.osdl.org/developer_bugzilla/show_bug.cgi?id=1180
	if(open(STDIN, "</dev/null")<0){
		&ld_exit(1, "ld_daemon: Could not open /dev/null");
	}
	if(open(STDOUT, ">>/dev/null")<0){
		&ld_exit(-1, "ld_daemon: Could not open /dev/null");
	}
	if(open(STDERR, ">>/dev/null")<0){
		&ld_exit(-1, "ld_daemon: Could not open /dev/null");
	}
}


# 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-z0-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);
}


# ld_find_cmd_path
# Find executable in path
# pre: cmd: command to find
#      path: ':' delimited paths to check
#      relative: if set, allow cmd to be a relative path, 
#                which is checked first
# return: path to command
#         undef if not found
sub ld_find_cmd_path
{
	my ($cmd, $path, $relative) = (@_);

	if (defined $relative  and $relative and -f "$cmd" ) {
		return $cmd;
	}
	if ($cmd =~ /^\// and -x "$cmd" ) {
		return $cmd;
	}
	if ($cmd =~ /\//) {
		return undef;
	}

	for my $p (split /:/, $path) {
		if ( -x "$p/$cmd" ) {
			return "$p/$cmd";
		}
	}
	return undef;
}

# ld_find_cmd_path
# Find executable in $ENV{'PATH'}
# pre: cmd: command to find
#      relative: if set, allow cmd to be a relative path, 
#                which is checked first
# return: path to command
#         undef if not found
sub ld_find_cmd
{
	return ld_find_cmd_path($_[0], $ENV{'PATH'}, $_[1]);
}
