#!/usr/bin/perl -w
######################################################################
# 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
#
######################################################################

# A Brief history of versions:
#
# From oldest to newest
# 1.1-1.144: ldirecord maintained in CVS HEAD branch
# 1.145-1.186: ldirectord.in maintained in CVS HEAD BRANCH
# 1.186-ha-VERSION: ldirectord.in maintained in mercurial

=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<try-restart>|B<reload>|B<force-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<@sysconfdir@/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<@sysconfdir@/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<@sysconfdir@/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 of 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, external and ping checks. If the timeout is
exceeded then the real server is declared dead.

If defined in a virtual server section then the global value is overridden.

If undefined then the value of negotiatetimeout is used.  negotiatetimeout
is also a global value that may be overriden by a per-virtual setting.

If both checktimeout and negotiatetimeout are unset, the default is used.

Default: 5 seconds

B<negotiatetimeout = >I<n>

Timeout in seconds for negotiate checks. 

If defined in a virtual server section then the global value is overridden.

If undefined then the value of connecttimeout is used.  connecttimeout is
also a global value that may be overriden by a per-virtual setting.

If both negotiatetimeout and connecttimeout are unset, the default is used.

Default: 30 seconds

B<checkinterval = >I<n>

Defines the number of second between server checks.

Default: 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/negotiatetimeout is additive, so if a connect check is used,
checkcount is 3 and checktimeout is 2 seconds, then a total of 6 seconds
worth of timeout will occur becore the check fails.

If defined in a virtual server section then the global value is overridden.

Default: 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: 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.

If defined in a virtual server section then the global value is overridden.

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.

Default: log directly to the file I</var/log/ldirectord.log>.


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.

If defined in a virtual server section then the global value is overridden.


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. The email timing accuracy of this
setting is dependent on the number of seconds defined in the checkinterval
configuration option.

If defined in a virtual server section then the global value is overridden.

Default: 0


B<emailalertstatus = >B<all>|B<none>|B<starting>|B<running>|B<stopping>|B<reloading>,...

Comma delimited list of server states in which email alerts should be sent.
B<all> is a short-hand for
"B<starting>,B<running>,B<stopping>,B<reloading>".  If B<none> is
specified, no other option may be specified, otherwise options are ored
with each other.

If defined in a virtual server section then the global value is overridden.

Default: all


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

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


B<supervised = >B<yes>|B<no>

If I<yes>, then ldirectord 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.

Default: I<no>


B<fork = >B<yes>|B<no>

If I<yes>, then ldirectord will spawn a child proccess for every virtual server,
and run checks against the real servers from them.  This will increase response
times to changes in real server status in configurations with many virtual
servers.  This may also use less memory then running many seperate instances of
ldirectord.  Child processes will be automaticly restarted if they die.

Default: I<no>


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.

This side-effect can be avoided by running the following:

echo 1 > /proc/sys/net/ipv4/vs/expire_quiescent_template

If the proc file isn't present this probably means that
the kernel doesn't have lvs support, LVS support isn't loaded,
or the kernel is too old to have the proc file. Running
ipvsadm as root should load LVS into the kernel if it is possible.

If I<no>, then the real or failback servers will be removed
from the kernel's LVS table. The default is I<yes>.

If defined in a virtual server section then the global value is overridden.

Default: I<yes>


=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. If omitted then a
weight of 1 will be used. The last two arguments are also 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
For TCP and UDP (non fwmark) virtual services, unless the forwarding method
is B<masq> and the IP address of a real server is non-local (not present on
a interface on the host running ldirectord) then the port of the real
server will be set to that of its virtual service. That is, port-mapping is
only available to if the real server is another machine and the forwarding
method is B<masq>.  This is due to the way that the underlying LVS code in
the kernel functions.

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

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

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 = >B<dns>|B<ftp>|B<http>|B<https>|B<imap>|B<imaps>|B<ldap>|B<mysql>|B<nntp>|B<none>|B<oracle>|B<pgsql>|B<pop>|B<pops>|B<radius>|B<simpletcp>|B<sip>|B<smtp>

The type of service to monitor when using checktype=negotiate. None denotes
a service that will not be monitored. 

simpletcp sends the B<request> string to the server and tests it against
the B<receive> regexp. The other types of checks connect to the server
using the specified protocol. Please see the B<request> and B<receive>
sections for protocol specific information.

Default:

=over 4

=item * Virtual server port is 21: ftp

=item * Virtual server port is 25: smtp

=item * Virtual server port is 53: dns

=item * Virtual server port is 80: http

=item * Virtual server port is 110: pop

=item * Virtual server port is 119: nntp

=item * Virtual server port is 143: imap

=item * Virtual server port is 389: ldap

=item * Virtual server port is 443: https

=item * Virtual server port is 993: imaps

=item * Virtual server port is 995: pops

=item * Virtual server port is 1521: oracle

=item * Virtual server port is 1812: radius

=item * Virtual server port is 3306: mysql

=item * Virtual server port is 5432: pgsql

=item * Virtual server port is 5060: sip

=item * Otherwise: none

=back 4


B<checkcommand = ">I<path to script>B<">

This setting is used if checktype is external and is the command to be run
to check the status of a real server. It should exit with status 0 if
everything is ok, or non-zero otherwise.

Four parameters are passed to the script:

=over 4

=item * virtual server ip/firewall mark

=item * virtual server port

=item * real server ip

=item * real server port

=back 4

Default: /bin/true

B<checkport = >I<n>

Number of port to monitor. Sometimes check port differs from service port.

Default: port specified for each 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, Oracle or PostgeSQL check, this should be an SQL query.
The data returned is not checked, only that the
answer is one or more rows.  This is a required setting.

For a simpletcp check, this string is sent verbatim except any occurances
of \n are replaced with a new line character.

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

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

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

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.

Default: GET

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<">

For FTP, IMAP, LDAP, MySQL, Oracle, POP and PostgreSQL, the username
used to log in.

For Radius the passwd is used for the attribute User-Name.

For SIP, the username is used as both the to and from address for an
OPTIONS query.

Default:

=over 4

=item * FTP: Anonymous

=item * MySQL Oracle, and PostgreSQL: Must be specified in the configuration

=item * SIP: ldirectord\@<hostname>, hostname is derived as per the passwd
        option below.

=item * Otherwise: empty string, which denotes that
	case authentication will not be attempted.

=back 4

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

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

For Radius the passwd is used for the attribute User-Password.

Default:

=over 4

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

=item * Otherwise: empty string.
	In the case of LDAP, MySQL, Oracle, and PostgreSQL this means
	that authentication will not be performed.

=back 4

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

Database to use for MySQL, Oracle 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<secret = ">I<radiussecret>B<">

Secret to use for Radius servers, this is the secret used to perform an
Access-Request with the username (set by B<login> above) and passwd (set by
B<passwd> above).

Default: empty string

B<scheduler => I<scheduler_name>

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

Default: "wrr"

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. If a firewall
mark then the protocol must be fwm.

Default:

=over 4

=item * Virtual is an IP address and port, and the port is not 53: tcp

=item * Virtual is an IP address and port, and the port is 53: udp

=item * Virtual is a firewall mark: fwm

=back 4


=head1 FILES

B<@sysconfdir@/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(
	    $VERSION_STR
	    $AUTOCHECK
	    $CHECKINTERVAL
	    $LDIRECTORD
	    $LDIRLOG
	    $NEGOTIATETIMEOUT
	    $DEFAULT_NEGOTIATETIMEOUT
	    $RUNPID
	    $CHECKTIMEOUT
	    $DEFAULT_CHECKTIMEOUT
	    $CHECKCOUNT
	    $QUIESCENT
	    $FORKING
	    $EMAILALERT
	    $EMAILALERTFREQ
	    $EMAILALERTSTATUS

	    $CALLBACK
	    $CFGNAME
	    $CMD
	    $CONFIG
	    $DEBUG
	    $FALLBACK
	    $SUPERVISED
	    $IPVSADM
	    $checksum
	    $DAEMON_STATUS
	    $DAEMON_STATUS_STARTING
	    $DAEMON_STATUS_RUNNING
	    $DAEMON_STATUS_STOPPING
	    $DAEMON_STATUS_RELOADING
	    $DAEMON_STATUS_ALL
	    $DAEMON_TERM
	    $DAEMON_HUP
	    $opt_d
	    $opt_h
	    $stattime
	    %LD_INSTANCE
	    @OLDVIRTUAL
	    @REAL
	    @VIRTUAL
	    $HOSTNAME
	    %EMAILSTATUS
	    %FORK_CHILDREN
	    $SERVICE_UP
	    $SERVICE_DOWN

	    $CRLF
);

$VERSION_STR = "Linux Director v1.186-ha-@VERSION@";

$DAEMON_STATUS_STARTING  = 0x1;
$DAEMON_STATUS_RUNNING   = 0x2;
$DAEMON_STATUS_STOPPING  = 0x4;
$DAEMON_STATUS_RELOADING = 0x8;
$DAEMON_STATUS_ALL       = $DAEMON_STATUS_STARTING | 
			   $DAEMON_STATUS_RUNNING  |
			   $DAEMON_STATUS_STOPPING |
			   $DAEMON_STATUS_RELOADING;

$SERVICE_UP	= 0;
$SERVICE_DOWN	=1;

# default values
$DAEMON_TERM      = undef;
$DAEMON_HUP       = undef;
$AUTOCHECK        = "no";
$CHECKINTERVAL    = 10;
$DEFAULT_CHECKTIMEOUT     = 5;
$CHECKTIMEOUT     = -1;
$CHECKCOUNT       = 1;
$LDIRECTORD       = ld_find_cmd("ldirectord", 1);
if (! defined $LDIRECTORD) {
	$LDIRECTORD = "@sbindir@/ldirectord";
}
$LDIRLOG          = "/var/log/ldirectord.log";
$NEGOTIATETIMEOUT = -1;
$DEFAULT_NEGOTIATETIMEOUT = 30;
$RUNPID           = "/var/run/ldirectord";
$SUPERVISED       = "no";
$FORKING          = "no";
$QUIESCENT        = "yes";
$EMAILALERT	  = "";
$EMAILALERTFREQ	  = 0;
$EMAILALERTSTATUS = $DAEMON_STATUS_ALL;

$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 :sys_wait_h);
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("$VERSION_STR\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 = $opt_d ? 3 : 0;
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);
}

$DAEMON_STATUS = $DAEMON_STATUS_STARTING;
ld_init();
ld_setup();
ld_start();
ld_cmd_children("start", %LD_INSTANCE);
$DAEMON_STATUS = $DAEMON_STATUS_RUNNING;
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;


	# 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 "@sysconfdir@/ha.d/$CONFIG" ) {
		$CONFIG = "@sysconfdir@/ha.d/$CONFIG";
	} elsif ( -f "@sysconfdir@/ha.d/conf/$CONFIG" ) {
		$CONFIG = "@sysconfdir@/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 "ldirectord is stopped for $CONFIG\n";
			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 eq "yes" || $opt_d) {
		&ld_log("Starting $VERSION_STR with pid: $$");
        } else {
		&ld_log("Starting $VERSION_STR 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 (defined $DAEMON_TERM) {
		$SIG{'__DIE__'} = "IGNORE";
		$SIG{"$signal"} = "IGNORE";
		die("Exit Handler Repeatedly Called\n");
	}
	$DAEMON_TERM = $signal;
	$DAEMON_STATUS = $DAEMON_STATUS_STOPPING;
}

sub ld_process_term
{
	$DAEMON_STATUS = $DAEMON_STATUS_STOPPING;
	ld_cmd_children("stop", %LD_INSTANCE);
	ld_stop();
	&ld_log("Linux Director Daemon terminated on signal: $DAEMON_TERM");
	&ld_rm_file("$RUNPID.$CFGNAME.pid");
	&ld_exit(0, "Linux Director Daemon terminated on signal: $DAEMON_TERM");
}

sub ld_handler_hup
{
	$DAEMON_HUP=1;
}

sub ld_process_hup
{
	&ld_log("Reloading Linux Director Daemon config on signal");
	$DAEMON_HUP = undef;
	&reread_config();
}


sub check_signal
{
	if (defined $DAEMON_TERM) {
		ld_process_term();
	}
	if (defined $DAEMON_HUP) {
		ld_process_hup();
	}
}

sub reread_config
{
	@OLDVIRTUAL = @VIRTUAL;
	my %OLD_INSTANCE = %LD_INSTANCE;
	my %RELOAD;
	my %STOP;
	my %START;
	my $child;
	$DAEMON_STATUS = $DAEMON_STATUS_RELOADING;
	eval {
		&read_config();

		foreach $child (keys %LD_INSTANCE) {
			if (defined $OLD_INSTANCE{$child}) {
				$RELOAD{$child} = 1;
			}
			else {
				$START{$child} = 1;
			}
		}

		foreach $child (keys %OLD_INSTANCE) {
			if (not defined $LD_INSTANCE{$child}) {
				$STOP{$child} = 1;
			}
		}

		&ld_cmd_children("stop", %STOP);
		&ld_cmd_children("reload_or_start", %RELOAD);
		&ld_cmd_children("start", %START);

		foreach my $vid (keys %FORK_CHILDREN) {
			&ld_log("Killing child $vid (PID=$FORK_CHILDREN{$vid})");
			kill 15, $FORK_CHILDREN{$vid};
		}

		&ld_setup();
		&ld_start();
	};
	if ($@) {
		@VIRTUAL = @OLDVIRTUAL;
		%LD_INSTANCE = %OLD_INSTANCE;
	}
	$DAEMON_STATUS = $DAEMON_STATUS_RUNNING;
	undef @OLDVIRTUAL;
}

sub parse_emailalertstatus
{
	my ($line, $arg) = (@_);

	my @s = split/\s*,\s*/, $arg;
	my $none = 0;
	my $status = 0;

	for my $i (@s) {
		if ($i eq "none") {
			$none++;
		}
	}

	for my $i (@s) {
		if ($i eq "none") {
			next;
		}
		elsif ($i eq "all") {
			$status = $DAEMON_STATUS_ALL;
		}
		elsif ($i eq "starting") {
			$status |= $DAEMON_STATUS_STARTING;
		}
		elsif ($i eq "stopping") {
			$status |= $DAEMON_STATUS_STOPPING;
		}
		elsif ($i eq "running") {
			$status |= $DAEMON_STATUS_RUNNING;
		}
		elsif ($i eq "reloading") {
			$status |= $DAEMON_STATUS_RELOADING;
		}
		else {
			&config_error($line,
				      "invalid email alert status at: \"$i\"")
		}
		if ($none > 0) {
			&config_error($line, "invalid email alert status: " .
				      "\"$i\" specified with \"none\"");
		}
	}
	return $status;
}

sub read_config
{
	undef @VIRTUAL;
	undef @REAL;
	undef $CALLBACK;
	undef %LD_INSTANCE;
	undef $checksum;
	$stattime = 0;
	my %virtual_seen;
	open(CFGFILE, "<$CONFIG") or
		&config_error(0, "can not open file $CONFIG");
	my $line = 0;
	my $linedata;
	while(<CFGFILE>) {
		$line++;
		$linedata = $_;
		outer_loop:
		if ($linedata =~ /^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{checkcommand} = "/bin/true";
			$vsrv{request} = "/";
			$vsrv{receive} = "";
			$vsrv{login} = "";
			$vsrv{passwd} = "";
			$vsrv{database} = "";
			$vsrv{checktimeout} = -1;
			$vsrv{checkcount} = -1;
			$vsrv{negotiatetimeout} = -1;
			$vsrv{num_connects} = 0;
			$vsrv{httpmethod} = "GET";
			$vsrv{secret} = "";
			push(@VIRTUAL, \%vsrv);
			while(<CFGFILE>) {
				$line++;
				$linedata=$_;
				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*(.*)/){
					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" || $1 eq "external") ) {
						$vsrv{checktype} = $1;
					} else {
						&config_error($line, "checktype must be \"connect\", \"negotiate\", \"on\", \"off\", \"ping\", \"external\" or a positive number");
					}
				} elsif ($rcmd =~ /^checkcommand\s*=\s*(.*)/){
                                        $1 =~ /(.+)/ or &config_error($line, "invalid external script");
                                        $vsrv{checkcommand} = $1;
				} elsif ($rcmd =~ /^checktimeout\s*=\s*(.*)/){
                                        $1 =~ /(\d+)/ && $1 or &config_error($line, "invalid check timeout");
                                        $vsrv{checktimeout} = $1;
				} elsif ($rcmd =~ /^connecttimeout\s*=\s*(.*)/){
					&config_error($line,
						"connecttimeout directive " .
						"deprecated in favour of " .
						"negotiatetimeout");
				} elsif ($rcmd =~ /^negotiatetimeout\s*=\s*(.*)/){
                                        $1 =~ /(\d+)/ && $1 or &config_error($line, "invalid negotiate timeout");
                                        $vsrv{negotiatetimeout} = $1;
				} elsif ($rcmd =~ /^checkcount\s*=\s*(.*)/){
                                        $1 =~ /(\d+)/ && $1 or &config_error($line, "invalid check count");
                                        $vsrv{checkcount} = $1;
				} elsif ($rcmd =~ /^checkinterval\s*=\s*(.*)/){
                                        $1 =~ /(\d+)/ && $1 or &config_error($line, "invalid checkinterval");
                                        $vsrv{checkinterval} = $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 =~ /^secret\s*=\s*\"(.*)\"/) {
					$1 =~ /(.+)/ or &config_error($line, "invalid secret");
					$vsrv{secret} = $1;
				} elsif ($rcmd =~ /^load\s*=\s*\"(.*)\"/) {
					$1 =~ /(\w+)/ or &config_error($line, "invalid string for load testing");
					$vsrv{load} = $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*(.*)/) {
					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*(.*)/) {
					$1 =~ /(\w+)/ && ($1 eq "dns"	||
							  $1 eq "ftp"	||
							  $1 eq "http"	||
							  $1 eq "https"	||
							  $1 eq "imap"	||
							  $1 eq "imaps"	||
							  $1 eq "ldap"	||
							  $1 eq "nntp"	||
							  $1 eq "mysql"	||
							  $1 eq "none"	||
							  $1 eq "oracle"||
							  $1 eq "pop"	||
							  $1 eq "pops"	||
							  $1 eq "radius"||
							  $1 eq "pgsql"	||
							  $1 eq "sip"	||
							  $1 eq "smtp"	||
							  $1 eq "simpletcp")
					    or &config_error($line,
							     "service must " .
							     "be dns, ftp, " .
							     "http, https, " .
							     "imap, imaps, " .
							     "ldap, nntp, "  .
							     "mysql, none, " .
							     "oracle, "      .
							     "pop, pops, "   .
							     "radius, "      .
							     "pgsql, "       .
							     "simpletcp, "   .
							     "sip or smtp");
					$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,
							       \%vsrv);
                                } 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;
				} elsif  ($rcmd =~ /^emailalertstatus\s*=\s*(.*)/) {
					$vsrv{emailalertstatus} = &parse_emailalertstatus($line, $1);
				} else {
					&config_error($line, "Unknown command \"$linedata\"");
				}
				undef $linedata;
			}
			# 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;

			unless(defined($linedata)) {
				last;
			}
			#Arggh a goto :(
			goto outer_loop;
		}
		next if ($linedata =~ /^\s*$/ || $linedata =~ /^\s*#/);
		if ($linedata  =~ /^checktimeout\s*=\s*(.*)/) {
			($1 =~ /(\d+)/ && $1 && $1>0) or &config_error($line, 
					"invalid check timeout value");
			$CHECKTIMEOUT = $1;
		} elsif ($linedata  =~ /^connecttimeout\s*=\s*(.*)/) {
			&config_error($line,
					"connecttimeout directive " .
					"deprecated in favour of " .
					"negotiatetimeout");
		} elsif ($linedata  =~ /^negotiatetimeout\s*=\s*(.*)/) {
			($1 =~ /(\d+)/ && $1 && $1>0) or &config_error($line, 
					"invalid negotiate timeout value");
			$NEGOTIATETIMEOUT = $1;
		} elsif ($linedata  =~ /^checkinterval\s*=\s*(.*)/) {
			$1 =~ /(\d+)/ && $1 or &config_error($line, 
					"invalid check interval value");
			$CHECKINTERVAL = $1;
		} elsif ($linedata  =~ /^checkcount\s*=\s*(.*)/) {
			$1 =~ /(\d+)/ && $1 or &config_error($line, 
					"invalid check count value");
			$CHECKCOUNT = $1;
		} elsif ($linedata  =~ /^fallback\s*=\s*(.*)/) {
			my $tcp = parse_fallback($line, $1, undef);
			my $udp = parse_fallback($line, $1, undef);
                        &_ld_read_config_fallback_resolve($line, "tcp", $tcp);
			&_ld_read_config_fallback_resolve($line, "udp", $udp);
			$FALLBACK = { "tcp" => $tcp, "udp" => $udp };
		} elsif ($linedata  =~ /^autoreload\s*=\s*(.*)/) {
			($1 eq "yes" || $1 eq "no")
			    or &config_error($line, 
			    		"autoreload must be 'yes' or 'no'");
			$AUTOCHECK = $1;
		} elsif ($linedata  =~ /^callback\s*=\s*\"(.*)\"/) {
			$CALLBACK = $1;
		} elsif ($linedata  =~ /^logfile\s*=\s*\"(.*)\"/) {
			my $tmpLDIRLOG = $LDIRLOG;
			$LDIRLOG = $1;
			if (&ld_openlog()) {
				$LDIRLOG = $tmpLDIRLOG;
				&config_error($line, 
						"unable to open logfile: $1");
			}
		} elsif ($linedata  =~ /^execute\s*=\s*(.*)/) {
			$LD_INSTANCE{$1} = 1;
                } elsif ($linedata  =~ /^fork\s*=\s*(.*)/) {
                        ($1 eq "yes" || $1 eq "no")
                            or &config_error($line, "fork must be 'yes' or 'no'");
                        $FORKING = $1;
		} elsif ($linedata  =~ /^supervised/) {
			if (($linedata  =~ /^supervised\s*=\s*(.*)/) and
			    ($1 eq "yes" || $1 eq "no")) {
				$SUPERVISED = $1;
			}
			elsif ($linedata  =~ /^supervised\s*$/) {
				$SUPERVISED = "yes";
				&config_warn($line,
					"please update your config not to " .
					"use a bare supervised directive");
			}
			else {
				&config_error($line,
					"supervised must be 'yes' or 'no'");
			}
		} elsif ($linedata  =~ /^quiescent\s*=\s*(.*)/) {
			($1 eq "yes" || $1 eq "no")
			    or &config_error($line, 
			    		"quiescent must be 'yes' or 'no'");
			$QUIESCENT = $1;
		} elsif  ($linedata  =~ /^emailalert\s*=\s*(.*)/) {
			$1 =~ /(.+)/ or &config_error($line,
					"no email address specified");
			$EMAILALERT = $1;
		} elsif  ($linedata  =~ /^emailalertfreq\s*=\s*(\d*)/) {
			$1 =~ /(\d+)/ or &config_error($line,
					"invalid email alert frequency");
			$EMAILALERTFREQ = $1;
		} elsif  ($linedata  =~ /^emailalertstatus\s*=\s*(.*)/) {
			$EMAILALERTSTATUS = &parse_emailalertstatus($line, $1);
		} else {
			if ($linedata  =~ /^timeout\s*=\s*(.*)/) {
				&config_error($line, 
						"timeout directive " .
						"deprecated in favour of " .
						"checktimeout and " .
						"negotiatetimeout");
			}
			&config_error($line, "Unknown command $linedata ");
		}
	}
	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 according to the value of
#       $vsrv->{port}
# 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})){
			$vsrv->{service} = ld_port_to_service($vsrv->{port});
		}
	}
}


# ld_service_to_port
# Resolve an ldirectord service name from its port number
# pre: port: port number of the service
# return: port name
#         "none" if the service is unknown

sub ld_port_to_service
{
	my ($port) = (@_);

	if ($port eq 21)	{ return "ftp"; }
	if ($port eq 25)	{ return "smtp"; }
	if ($port eq 53)	{ return "dns"; }
	if ($port eq 80)	{ return "http"; }
	if ($port eq 110)	{ return "pop"; }
	if ($port eq 119)	{ return "nntp"; }
	if ($port eq 143)	{ return "imap"; }
	if ($port eq 389)	{ return "ldap"; }
	if ($port eq 443)	{ return "https"; }
	if ($port eq 993)	{ return "pops"; }
	if ($port eq 995)	{ return "imaps"; }
	if ($port eq 1521)	{ return "oracle"; }
	if ($port eq 1812)	{ return "radius"; }
	if ($port eq 3306)	{ return "mysql"; }
	if ($port eq 5060)	{ return "sip"; }
	if ($port eq 5432)	{ return "pgsql"; }

	return "none";
}


# ld_service_to_port
# Resolve the port number from an ldirectord service name
# pre: service: name of the service
# return: port number
#         undef if the service is unknown

sub ld_service_to_port
{
	my ($service) = (@_);

	if ($service eq "ftp")		{ return 21; }
	if ($service eq "smtp")		{ return 25; }
	if ($service eq "dns")		{ return 53; }
	if ($service eq "http")		{ return 80; }
	if ($service eq "pop")		{ return 110; }
	if ($service eq "nntp")		{ return 119; }
	if ($service eq "imap")		{ return 143; }
	if ($service eq "ldap")		{ return 389; }
	if ($service eq "https")	{ return 443; }
	if ($service eq "imaps")	{ return 993; }
	if ($service eq "pops")		{ return 995; }
	if ($service eq "oracle")	{ return 1521; }
	if ($service eq "radius")	{ return 1812; }
	if ($service eq "mysql")	{ return 3306; }
	if ($service eq "sip")		{ return 5060; }
	if ($service eq "pgsql")	{ return 5432; }

	return undef;
}


# ld_checkport
# Resolve the port to connect to for service checks
# Note: Should only be used inside service checks,
#       as its not the same as the port of the real server
# pre: v: virtual service
#      r: real servier
# return: port number
#         undef if the service is unknown

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

	if (defined $v->{checkport}) {
		return $v->{checkport};
	}
	if ($r->{port} > 0) {
		return $r->{port};
	}

	return ld_service_to_port($v->{service});
}


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

        unless($fallback) {
                return;
        }

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

        unless($fallback->{"port"}) {
                return;
        }

	$fallback->{port} = &ld_getservbyname($fallback->{port}, $protocol) or
	        &config_error($line, "invalid port 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 " .
			"greater 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;
	}
	else {
		$new_rsrv->{"weight"} = 1;
	}

	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, $vsrv) = (@_);

	my $server;
	my $port;
	my $fwd;

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

        $server=$1;
        $port=$3;
        $fwd=$5;

	if (not defined($port) and defined($vsrv)) {
		$port = $vsrv->{"port"};
	}

        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"=>$server, "port"=>$port, "forward"=>$fwd,
		"weight"=>1});
}


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

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

	my $msg_prefix = "$prefix [$$]";
	if ($line > 0) {
		$msg_prefix .= " reading file $CONFIG at line $line";
	}
	$msg = "$msg_prefix: $msg";

	if ($opt_d or $DAEMON_STATUS == $DAEMON_STATUS_STARTING) {
		print STDERR $msg;
	} 
	else {
		&ld_log("$msg");
	}
}


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

	__config_log($line, "Warning", $msg);
}


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

	__config_log($line, "Error", $msg);
	if ($DAEMON_STATUS == $DAEMON_STATUS_STARTING) {
		&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});
			my $port=ld_checkport($v, $r);
        		if (defined $$r{request} && defined $$r{receive}) {
				my $uri = $$r{request};
				$uri =~ s/^\///g;
				if ($$r{request} =~ /$$v{service}:\/\//) {
					$$r{url} = "$uri";
				} else {
					$$r{url} = "$$v{service}:\/\/$$r{server}:$port\/$uri";
				}
			} else {
				my $uri = $$v{request};
				$uri =~ s/^\///g;
				$$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;
			}
		}

		# checktimeout and negotiate timeout are 
		# mutual defaults for each other, so calculate
		# checktimeout in a tempoary variable so as not
		# to affect the calculation of negotiatetimeout.

		my $checktimeout = $$v{checktimeout};
		if ($checktimeout < 0) {
			$checktimeout = $$v{negotiatetimeout};
		}
		if ($checktimeout < 0) {
			$checktimeout = $CHECKTIMEOUT;
		}
		if ($checktimeout < 0) {
			$checktimeout = $NEGOTIATETIMEOUT;
		}
		if ($checktimeout < 0) {
			$checktimeout = $DEFAULT_CHECKTIMEOUT;
		}

		if ($$v{negotiatetimeout} < 0) {
			$$v{negotiatetimeout} = $$v{checktimeout};
		}
		if ($$v{negotiatetimeout} < 0) {
			$$v{negotiatetimeout} = $NEGOTIATETIMEOUT;
		}
		if ($$v{negotiatetimeout} < 0) {
			$$v{negotiatetimeout} = $CHECKTIMEOUT;
		}
		if ($$v{negotiatetimeout} < 0) {
			$$v{negotiatetimeout} = $DEFAULT_NEGOTIATETIMEOUT;
		}

		$$v{checktimeout} = $checktimeout;

		if ($$v{checkcount} < 0) {
			$$v{checkcount} = $CHECKCOUNT;
		}
	}
}

# ld_read_ipvsadm
#
# Net::FTP seems to set the input record separator ($\) to null
# putting IO into slurp (whole file at a time, rather than line at a time)
# mode. Net::FTP does this using local $\, which should mean
# that the change doesn' effect code here, but it does. It also
# seems to be imposible to turn it off, by say setting $\ back to '\n'
# Perhaps there is more to this than meets the eye. Perhaps its a perl bug.
# In any case, this should fix the problem.
#
# This should not affect pid or config file parsing as they are called
# before Net::FTP and as this appears to be a bit of a work around,
# I'd rather use it in as few places as possible
#
# Observed with perl v5.8.8 (Debian's perl 5.8.8-6)
# -- Horms, 17th July 2005
sub ld_readline
{
	my ($fd, $buf) = (@_);
	my $line;

	# Uncomment the following line to turn off this work around
	# return readline($fd);

	$line = shift @$buf;
	if (defined $line) {
		return $line . "\n";
	}

	push @$buf, split /\n/, readline($fd);

	$line = shift @$buf;
	if (defined $line) {
		return $line . "\n";
	}

	return undef;
}

# 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;
	my $buf = [];
	my $fh;
	my $line;

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

	# Skip the first three lines
	$line = ld_readline($fh, $buf); 
	$line = ld_readline($fh, $buf); 
	$line = ld_readline($fh, $buf);

	while (1) {
		$line = ld_readline($fh, $buf);
		if (not defined $line) {
			last;
		}
		if ($line =~ /^(\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 ($line =~ /^(\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 ($line =~ /^(\w+)\s+(\d+\.\d+\.\d+\.\d+\:\d+|\d+)\s+(\w+)/) {
			$real_service = "$2 ".lc($1);
			$oldsrv{"$real_service"} = {"real"=>{}, "scheduler"=>$3};
		} elsif ($line =~ /^  ->\s+(\d+\.\d+\.\d+\.\d+\:\d+)\s+(\w+)\s+(\d+)/) {
			if (not defined( $real_service)) {
				&ld_debug(2, "Real server read from ipvsadm " .
					  "doesn't seem to be inside a " .
					  "virtual service: \"$line\"\n");
				next;
			}
			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};
		} else {
			&ld_debug(2, "Unknown line read from ipvsadm: " .
				  "\"$line\"\n");
			next;
		}
	}
	close($fh);

        return(\%oldsrv);
}

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

	# 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}:$fallback->{port}"});
		}

		for $nr (@$nreal) {
			my $real_str = "$nr->{server}:$nr->{port}";
			if (! defined($or->{$real_str}) or
					$or->{$real_str}->{weight} == 0) {
				$server_down->{$real_str} = [$nv, $nr];
				#service_set($nv, $nr, "down", "force");
			}
			else {
				if (defined $server_down->{$real_str}) {
					delete($server_down->{$real_str});
				}
				service_set($nv, $nr, "up", "force");
			}
			delete($or->{$real_str});
		}

		# remove remaining entries for real servers
		for my $k (keys %$or) {
			purge_untracked_service($nv, $k, "start");
			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;
		}
		purge_virtual($nv, "start");
	}
}


sub ld_cmd_children
{
	my ($cmd, %children) = (@_);
	# instantiate other ldirectord, if specified
	my $child;
	foreach $child (keys %children) {
		if ($cmd eq "reload_or_start") {
			if (&system_wrapper("$LDIRECTORD $child reload")) {
				&system_wrapper("$LDIRECTORD $child start");
			}
		}
		else {
			&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}) {
				purge_service($v, $r, "stop");
			}
		}
		purge_virtual($v, "stop");
	}
}


sub ld_main
{
	# Main failover checking code
	while (1) {
                if ($FORKING eq 'yes') {
                        foreach my $v (@VIRTUAL) {
                                my $virtual_id = get_virtual_id_str($v);
                                if (!exists($FORK_CHILDREN{$virtual_id})) {
                                        &ld_log("Child not running for $virtual_id, spawning");
                                        my $pid = fork;
                                        if (!defined($pid)) {
                                                &ld_log("fork failed");
                                        } elsif ($pid == 0) {
                                                run_child($v);
                                        } else {
                                                $FORK_CHILDREN{get_virtual_id_str($v)} = $pid;
                                                &ld_log("Spawned child $virtual_id PID=$pid");
                                        }
                                } elsif (waitpid($FORK_CHILDREN{get_virtual_id_str($v)}, WNOHANG)) {
                                        delete $FORK_CHILDREN{get_virtual_id_str($v)};
                                }
                        }
                        check_signal();
                        if (!check_cfgfile()) {
                                sleep 1;
                        }
                        
                        check_signal();
                        
                } else {
                        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);
                                        check_signal();
                                        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;
                                                }
                                        }
                                        _check_real($v, $r);
                                        push(@real_checked, $real_id);
                                }
                        }
                        check_signal();
                        if (!check_cfgfile()) {
                                sleep $CHECKINTERVAL;
                        }
                                
                        check_signal();
                        ld_emailalert_resend();
        
                        check_signal();
                }
	}
}

sub run_child
{
        my $v = shift;
        # Just exit on signals
        $SIG{'INT'} = "DEFAULT";
        $SIG{'QUIT'} = "DEFAULT";
        $SIG{'ILL'} = "DEFAULT";
        $SIG{'ABRT'} = "DEFAULT";
        $SIG{'FPE'} = "DEFAULT";
        $SIG{'SEGV'} = "DEFAULT";
        $SIG{'TERM'} = "DEFAULT";

        $SIG{'BUS'} = "DEFAULT";
        $SIG{'SYS'} = "DEFAULT";
        $SIG{'XCPU'} = "DEFAULT";
        $SIG{'XFSZ'} = "DEFAULT";

        $SIG{'IOT'} = "DEFAULT";

        $SIG{'PIPE'} = "IGNORE";
        $SIG{'HUP'} = sub { exit 1 };
        
        my $real = $$v{real};
        my $virtual_id = get_virtual_id_str($v);
        $0 = $virtual_id;
        foreach my $r (@$real) {
                service_set($v, $r, "down", "force");
        }
        while (1) {
                foreach my $r (@$real) {
                        $0 = "$virtual_id checking $$r{server}";
                        _check_real($v, $r);
                }
                $0 = $virtual_id;
                sleep $CHECKINTERVAL;
                ld_emailalert_resend();
        }
}

sub _check_real
{
        my $v = shift;
        my $r = shift;

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

        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) == $SERVICE_UP);
                } elsif ($$v{service} eq "pop") {
                        $$r{num_connects} = 0 if (check_pop($v, $r) == $SERVICE_UP);
                } elsif ($$v{service} eq "pops") {
                        $$r{num_connects} = 0 if (check_pops($v, $r) == $SERVICE_UP);
                } elsif ($$v{service} eq "imap") {
                        $$r{num_connects} = 0 if (check_imap($v, $r) == $SERVICE_UP);
                } elsif ($$v{service} eq "imaps") {
                        $$r{num_connects} = 0 if (check_imaps($v, $r) == $SERVICE_UP);
                } elsif ($$v{service} eq "smtp") {
                        $$r{num_connects} = 0 if (check_smtp($v, $r) == $SERVICE_UP);
                } elsif ($$v{service} eq "ftp") {
                        $$r{num_connects} = 0 if (check_ftp($v, $r) == $SERVICE_UP);
                } elsif ($$v{service} eq "ldap") {
                        $$r{num_connects} = 0 if (check_ldap($v, $r) == $SERVICE_UP);
                } elsif ($$v{service} eq "nntp") {
                        $$r{num_connects} = 0 if (check_nntp($v, $r) == $SERVICE_UP);
                } elsif ($$v{service} eq "dns") {
                        $$r{num_connects} = 0 if (check_dns($v, $r) == $SERVICE_UP);
                } elsif ($$v{service} eq "sip") {
                        $$r{num_connects} = 0 if (check_sip($v, $r) == $SERVICE_UP);
                } elsif ($$v{service} eq "radius") {
                        $$r{num_connects} = 0 if (check_radius($v, $r) == $SERVICE_UP);
                } elsif ($$v{service} eq "mysql") {
                        $$r{num_connects} = 0 if (check_mysql($v, $r) == $SERVICE_UP);
                } elsif ($$v{service} eq "pgsql") {
                        $$r{num_connects} = 0 if (check_pgsql($v, $r) == $SERVICE_UP);
                } elsif ($$v{service} eq "oracle") {
                        $$r{num_connects} = 0 if (check_oracle($v, $r) == $SERVICE_UP);
		} elsif ($$v{service} eq "simpletcp") {
			$$r{num_connects} = 0 if (check_simpletcp($v, $r) == $SERVICE_UP);
                } else {
                        $$r{num_connects} = 0 if (check_none($v, $r) == $SERVICE_UP);
                }
        } 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 "external") {
                &ld_debug(2, "Checking external: real server=$real_id (virtual=$virtual_id)");
                check_external($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) == $SERVICE_UP) {
                        $$r{num_connects}++;
                } else {
                        $$r{num_connects} = 999999;
                }
        }
}

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();
	my $h = new  HTTP::Headers("Host" => $virtualhost);
	my $req = new HTTP::Request("$$v{httpmethod}", "$$r{url}", $h);
	my $res;

	# LWP does not seem to honour timeouts set using $ua->timeout()
	# for HTTPS. So use an alarm instead. This also has the advantage
	# of being cumulative timeout, rather than a per send/receive
	# timeout.
	eval {
		# LWP makes ungaurded calls to eval
		# which throw a fatal exception if they fail
		# Needless to say, this is completely stupid.
		# Resetting of $SIG{'__DIE__'} is also
		# needed now that alarm() is used.
		local $SIG{'__DIE__'} = "DEFAULT";
		local $SIG{'ALRM'} = sub { die "Timeout Alarm" };
		&ld_debug(4, "Timeout is $$v{negotiatetimeout}");
		&ld_debug(2, "Starting Check");
		alarm $$v{negotiatetimeout};

		&ld_debug(2, "Starting HTTP/HTTPS");
		$res = $ua->request($req);
		&ld_debug(2, "Finished HTTP/HTTPS");
		alarm 0; # Cancel the alarm
	};

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

	service_set($v, $r, "down");
	&ld_debug(3, "Headers " .  $res->headers->as_string);
	&ld_debug(2, "check_http: $$r{url} is down\n");
	return $SERVICE_DOWN;
}


sub check_smtp
{
	require Net::SMTP;
	my ($v, $r) = @_;
	my $port = ld_checkport($v, $r);

	&ld_debug(2, "Checking smtp: 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 $SERVICE_UP;
	} else {
		service_set($v, $r, "down");
		return $SERVICE_DOWN;
	}
}

sub check_pop
{
        require Mail::POP3Client;
        my ($v, $r) = @_;
	my $port = ld_checkport($v, $r);

        &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 $SERVICE_UP;
        }

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

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

sub check_pops
{
        require Mail::POP3Client;
        my ($v, $r) = @_;
	my $port = ld_checkport($v, $r);

        &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 $SERVICE_DOWN;
        }

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


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

sub check_imap
{
        require Net::IMAP::Simple;
        my ($v, $r) = @_;
	my $port = ld_checkport($v, $r);
        
        &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 $SERVICE_DOWN;
        }
        
        if($$v{login} ne "") {
                my $authres = $imap->login($$v{login},$$v{passwd});
                $imap->quit;
                if (!$authres) {
                        service_set($v, $r, "down");
                        return $SERVICE_DOWN;
                }
        }
        
        $imap->quit();
        service_set($v, $r, "up");
        return $SERVICE_UP;
}

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

        &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 $SERVICE_DOWN;
        }

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

        $imaps->quit();
        service_set($v, $r, "up");
        return $SERVICE_UP;
}

sub check_ldap
{
	my ($v, $r) = @_;
	require Net::LDAP;
	my $port = ld_checkport($v, $r);

	&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 $SERVICE_DOWN;
	}
		
	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 $SERVICE_DOWN;
	}

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


sub check_nntp
{
        use IO::Socket;
        use IO::Select;
        my ($v, $r) = @_;
        my $sock;
        my $s;
        my $buf;
	my $port = ld_checkport($v, $r);
	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 $SERVICE_DOWN;
        }
        $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_radius
{
        require Authen::Radius;

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

        &ld_debug(2, "Checking radius");

	my $port = ld_checkport($v, $r);
        my $radius;
        my $result = "";

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

                &ld_debug(2, "Starting Radius");
                $radius = new Authen::Radius(Host => "$$r{server}:$port",
					     Secret=>$$v{secret},
					     TimeOut=>$$v{negotiatetimeout},
					     Errmode=>'die');
                $result = $radius->check_pwd($$v{login}, $$v{passwd});
                &ld_debug(2, "Finished Radius");
                alarm 0; # Cancel the alarm
        };
        if ($result eq "") {
                &service_set($v, $r, "down");
                &ld_debug(3, "Deactivated service $$r{server}:$$r{port}: $@");
                &ld_debug(3, "Radius Error: ".$radius->get_error);
                return $SERVICE_DOWN;
        } else {
                &service_set($v, $r, "up");
                &ld_debug(3, "Activated service $$r{server}:$$r{port}");
                return $SERVICE_UP;
        }
}


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

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

sub check_sql_log_errstr
{
	my ($prefix, $errstr) = (@_);

	for $_ (split /\n/, $errstr) {
		&ld_debug(4, "$prefix $_\n");
	}

}

sub check_oracle
{
	return check_sql(@_, "Oracle", "");
}

sub check_sql
{
	require DBI;
	my ($v, $r, $dbd, $dbname) = @_;
	my $port = ld_checkport($v, $r);
	my ($dbh, $sth, $query, $row, $result);
	$result = $SERVICE_DOWN;
	$query = $$r{request};
	$query =~ s#^/##;
	unless ($$v{login} && $query) {
		&ld_log("Error: Must specify a login and request string " .
			"for MySQL, Oracle and PostgreSQL checks. " .
			"Not adding $$r{server}.\n");
		goto err_down;
	}
	$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) {
		check_sql_log_errstr("Failed to bind to $$r{server} with",
				     DBI->errstr);
		goto err_down;
	}
	$result--;
	$sth = $dbh->prepare($query);
	unless ($sth) {
		check_sql_log_errstr("Error preparing statement:",
				     $dbh->errstr);
		goto err_disconect;
	}

	# On error "execute" will return undef.
	# Otherwise it will return either "0E0"
	# (Some garbage to make 0 true) or > 1.
	$sth->execute;
	unless ($sth->rows) {
		check_sql_log_errstr("Error executing statement:",
				     $dbh->errstr, $dbh->err);
		goto err_finish;
	}

	# After calling "execute" $sth->{NUM_OF_FIELDS} will be greater
	# than zero for SELECT statements, and 0 for all other statements.
	#
	# For non-SELECT statements a non-undef value returned by
	# "execcute" inticates the number of rows returned.  "0E0" (Some
	# garbage to make 0 true) or > 1.  But testing for this isn't
	# particularly interesting as its quite valid for operations to
	# affect 0 rows. So for non-SELECT statements, if "execute"
	# doesn't return undef, consider the test a success.
	unless ($sth->{NUM_OF_FIELDS}) {
		goto out;
	}

	# For SELECT staements "execute" will always return a true
	# value unless an error occurs. A "fetch" operation is performed
	# to obtain the row returned by the SELECT statement. Again 0
	# rows is valid.
	#
	# I suspect that for at leaast some DB engines "execute" will
	# always succeed unless there is some bizzare internal error.
	# So it seems that in order to have a reasonable test "fetch"
	# needs to be called.
	#
	# I also wonder if having a table missing
	# will result in an error or just 0 rows returned. If the
	# latter is true then I guess we need to consider 0 rows an
	# error state. But I'll have the code consider 0 rows a success
	# for now leave this to be changed if testing proves it neccessary.

	# As it is important that the SELECT succeeded, rather than
	# how may rows it returns, just call "fetchrow_arrayref" once.
	#
	# I guess that in a pathalogical case the query may fail
	# at a particular row. But I'm not going to worry about that for
	# now.
	$row = $sth->fetchrow_arrayref;
	unless ($row && !$sth->err) {
		check_sql_log_errstr("Error fetching row:", $dbh->errstr);
		goto err_finish;
	}

out:
	$result = $SERVICE_UP;
err_finish:
	$sth->finish();
err_disconnect:
	$dbh->disconnect();
err_down:
	service_set($v, $r, $result == $SERVICE_UP ? "up" : "down");
	return $result;
}


sub check_connect
{
	my ($v, $r) = @_;
	my $port = ld_checkport($v, $r);

	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 $$r{server} (port $port)");
		alarm 0; # Cancel the alarm
	};
	if ($@) {
		&service_set($v, $r, "down");
		&ld_debug(3, "Deactivated service $$r{server}:$$r{port}: $@");
		return $SERVICE_DOWN;
	} else {
		&service_set($v, $r, "up");
		&ld_debug(3, "Activated service $$r{server}:$$r{port}");
		return $SERVICE_UP;
	}
}

sub check_external
{
	my ($v, $r) = @_;
	my $result;
	my $v_server;

	eval {
		local $SIG{'__DIE__'} = "DEFAULT";
		local $SIG{'ALRM'} = sub { die "Timeout Alarm" };
		&ld_debug(4, "Timeout is $$v{checktimeout}");
		alarm $$v{checktimeout};
		if (defined $$v{server}) {
		    $v_server = $$v{server};
		} else {
		    $v_server = $$v{fwm};
		}
		$result = system("$$v{checkcommand} $v_server $$v{port} " .
				 "$$r{server} $$r{port}");
		alarm 0;
		$result >>= 8;
	};
	if ($@ or $result != 0) {
		&service_set($v, $r, "down");
		&ld_debug(3, "Deactivated service $$r{server}:$$r{port}: " .
			  "$@ after calling $$v{checkcommand} with result " .
			  "$result");
		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 = ld_checkport($v, $r);

	&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{negotiatetimeout};

		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 $SERVICE_DOWN;
	} else {
		&service_set($v, $r, "up");
		&ld_debug(3, "Activated service $$r{server}:$$r{port}");
		return $SERVICE_UP;
	}
}


sub check_simpletcp
{
       my ($v, $r) = @_;
       my $d_port = ld_checkport($v, $r);

       &ld_debug(2, "Checking simpletcp server=$$r{server} port=$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{negotiatetimeout};

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

	       my $s_sockaddr = getsockname($sock);
	       my ($s_port, $s_addr) = sockaddr_in($s_sockaddr);
	       my $s_addr_str = inet_ntoa($s_addr);

	       &ld_debug(3, "Connected from $s_addr_str:$s_port to " .
		       $$r{server} . ":$d_port");

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

	       my $request = $$r{request};
	       $request =~ s/\\n/\n/g ;

	       &ld_debug(2, "Checking simpletcp server=$$r{server} port=$d_port request:\n$request");
	       print $sock $request;

	       my $ok;
	       my $reply;
	       while (<$sock>) {
		       &ld_debug(2, "Checking simpletcp server=$$r{server} port=$d_port receive=" . $$r{receive} ." got: $_\n");
		       if ( $_ =~ /$$r{receive}/ ) {
			       $ok = 1;
			       last;
		       }
	       }
	       alarm 0; # Cancel the alarm
	       close($sock);

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

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

sub check_ftp
{
	require Net::FTP;
	my ($v, $r) = @_;
	my $ftp;
	my $memory;
	my $debug = ($DEBUG > 2) ? 1 : 0;
	my $port = ld_checkport($v, $r);

	&ld_debug(2, "Checking ftp server=$$r{server} port=$port");
	&ld_debug(4, "Timeout is $$v{negotiatetimeout}");
	
	open(TMP,'+>', undef);

	# In some cases Net::FTP dies if there is a timeout
	eval {
		unless ($ftp = Net::FTP->new("$$r{server}:$port",
				Timeout=>$$v{negotiatetimeout},
				Debug=>$debug)) {
			die "Could not connect\n";
		}
		$ftp->login($$v{login}, $$v{passwd});
		$ftp->cwd("/");
		$ftp->binary();
		$ftp->pasv();
		$ftp->get("$$r{request}", *TMP);
		$ftp->quit();
	};
	if ($@) {
		&ld_debug(2, "Warning: $@");
	}

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

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

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


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{negotiatetimeout});
		 $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 $SERVICE_DOWN;
	}
 
	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 $SERVICE_UP;
		}
	}
 
	service_set($v,$r,"down");
	return $SERVICE_DOWN;
}


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 $SERVICE_UP;
		}
  		&ld_debug(2, "ping to $$r{server} timed out " .
					"(attempt " .  ($attempt + 1) . "/" . 
					$$v{"checkcount"} . ")\n");
	}

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


# 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 $SERVICE_UP;
}


# 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);
		my $log_str = "real server=" . get_real_id_str($r, $v) .
			      " (virtual=$virtual_id)";
		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  $log_str");
			} elsif ($state=~/down/i) {
				_service_down($v, $r, $force);
				&ld_debug(2, "Disabled $log_str");
			}
		}
	}
}


# _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 .= "($virtual_str)";

	my $server_str=$rservice . " " . $virtual_str;
	my $currenttime=time();
	if(defined($is_quiescent)) {
		if (defined($or)) {
                	&system_wrapper("$IPVSADM -e "
					. "$ipvsadm_args $rforw -w 0");
		}
		else {
                	&system_wrapper("$IPVSADM -a "
					. "$ipvsadm_args $rforw -w 0");
		}
	       	&ld_log("Quiescent $log_args (Weight set to 0)");
		&ld_emailalert_send("Quiescent $log_args (Weight set to 0)",
				    $v, $rservice, $currenttime);
        }
	else {
                &system_wrapper("$IPVSADM -d $ipvsadm_args");
	        &ld_log("Deleted $log_args");
		&ld_emailalert_send("Deleted $log_args", $v,
				    $rservice, $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}}) 
		    .  &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};
        }
        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)");
			&ld_emailalert_send("Restored $log_args " .
					    "(Weight set to $rwght)",
					    $v, $rservice, 0);
                }
        }
        else {
                &system_wrapper("$IPVSADM -a $ipvsadm_args");
	        &ld_log("Added $log_args (Weight set to $rwght)");
		&ld_emailalert_send("Added $log_args (Weight set to $rwght)",
				    $v, $rservice, 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}) and
				 (! 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->{weight}, "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)) {
		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} . ":" . $fallback->{port},
			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} . ":" .  $fallback->{port},
			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 ( not defined($FALLBACK) ) {
		return undef;
	}

	# If the global fallback has a port, it can be used as is
	if (defined($FALLBACK->{$virtual->{"protocol"}}->{"port"})) {
		return $FALLBACK->{$virtual->{"protocol"}};
	}

	# Else create an anonymous fallback
	my %anon_fallback = %{$FALLBACK->{$virtual->{"protocol"}}};
	$anon_fallback{"port"} = $virtual->{"port"};

	return \%anon_fallback;
}


# Used during stop, start and reload to remove stale real servers from LVS
sub purge_untracked_service
{
	my ($v, $rservice, $tag) = (@_);

	my $log_arg = "Purged real server ($tag): $rservice (" . 
		      &get_virtual($v) . ")";

	&system_wrapper("$IPVSADM -d $v->{proto} " . &get_virtual($v) . 
			" -r $rservice");
	&ld_log($log_arg);
	&ld_emailalert_send($log_arg, $v, $rservice, 0);
}


# Used during stop, start and reload to remove stale real servers from LVS
sub purge_service 
{
	my ($v, $r, $tag) = (@_);

	purge_untracked_service($v, "$r->{server}:$r->{port}", $tag);
	_status_down($v, $r);
}


# Used during stop, start and reload to remove stale virtual services from LVS
sub purge_virtual 
{
	my ($v, $tag) = (@_);

	&system_wrapper("$IPVSADM -D $v->{proto} " .  &get_virtual($v));
	&ld_log("Purged virtual server ($tag): " .  &get_virtual($v));
}


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 (defined($CALLBACK) and -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 eq "yes") {
		# 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 eq "yes") {
		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);
}


sub daemon_status_str
{
	if ($DAEMON_STATUS == $DAEMON_STATUS_STARTING) {
		return "starting";
	}
	elsif ($DAEMON_STATUS == $DAEMON_STATUS_RUNNING) {
		return "running";
	}
	elsif ($DAEMON_STATUS == $DAEMON_STATUS_STOPPING) {
		return "stopping";
	}
	elsif ($DAEMON_STATUS == $DAEMON_STATUS_RELOADING) {
		return "reloading";
	}
	return "UNKNOWN";
}


# ld_emailalert_send
# 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_send
{
	my ($subject, $v, $rserver, $currenttime) = (@_);
	my $emailmsg;
	my $emailfh;
	my $status = 0;
	my $to_addr;
	my $frequency;
	my $virtual_str;
	my $id;
	my $statusfilter;

	$frequency = defined $v->{emailalertfreq} ? $v->{emailalert} :
				$EMAILALERTFREQ;

	$virtual_str = &get_virtual($v);
	$id = "$rserver ($virtual_str)";

	if ($currenttime == 0 or $frequency == 0) {
		delete $EMAILSTATUS{"$id"};
	}
	else {
		$EMAILSTATUS{$id}->{v} = $v;
		$EMAILSTATUS{$id}->{alerttime} = $currenttime;
	}

	$statusfilter = defined $v->{emailalertstatus} ?  
			$v->{emailalertstatus} : $EMAILALERTSTATUS;
	if (($DAEMON_STATUS & $statusfilter) == 0) {
		return 0;
	}

	$to_addr = defined $v->{emailalert} ? $v->{emailalert} : $EMAILALERT;
	if ($to_addr eq "") {
		return 0;
	}

	use Mail::Send;

	&ld_log("emailalert: $subject");

	unless ($emailmsg = new Mail::Send Subject=>$subject, To=>$to_addr
			and $emailfh = $emailmsg->open
			and print $emailfh "Log-Message: $subject\n" .
					   "Daemon-Status: " .
					   &daemon_status_str() . "\n"
			and $emailfh->close) {
		&ld_log("failed to send email message\n");
		$status = 1;
	}

	return($status);
}


# ld_emailalert_resend
# Resend email alerts as neccessary
# pre: none
# post: EMAILSTATUS array is updated and alears are sent as neccessary
# return: none

sub ld_emailalert_resend
{
	my $currenttime = time();
	my $es;
	my $id;
	my $rserver;
	my $frequency;

	foreach $id (keys %EMAILSTATUS) {
		$es = $EMAILSTATUS{$id};
		$frequency = defined $es->{v}->{emailalertfreq} ? 
					$es->{v}->{emailalertfreq} :
					$EMAILALERTFREQ;
		$id =~ m/(.*) /;
		$rserver = $1;
		if ($currenttime - $es->{alerttime} < $frequency) {
			next;
		}
		&ld_emailalert_send("Inaccessible real server: $id", 
			       $es->{v}, $rserver, $currenttime);
	}
}

# 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) or &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" or
			$v->{"checktype"} eq "combined") {
		$check = $v->{"checktype"} . ":" . $v->{"service"};
	}
	elsif($v->{"checktype"} eq "external") {
		$check = $v->{"checktype"} . ":" . $v->{"checkcommand"};
	}
	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"} . ":" . $r->{"forward"} . ":"
		 . 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]);
}
