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

# Revision History :
#   0.5.0-0: Added code related to Sorry server and Max connection
#            - 2006/11/03 NTT COMWARE
#   1.0.0-0: Added code related to weight of real server and QoS
#            - 2007/10/12 NTT COMWARE
#   1.0.1-0: Added the code below.
#            configuration of realdowncallback, realrecovercallback,
#            and sessionless module.
#            - 2007/12/28 NTT COMWARE
#   1.0.2-0: Added the code below.
#            cookie insert with X-Forwarded-For module(cinsert_xf)
#            - 2008/1/14 Shinya TAKEBAYASHI
#   2.0.0-0: Added code related to sslid module.
#            cinsert_xf module is marged into cinsert module.
#            Added code related to syntax test of configuration.
#            Expanded checkcount setting to all service check.
#            - 2008/03/25 Norihisa NAKAI

use strict;

use vars qw(
    $AUTOCHECK
    $CALLBACK
    $CFGNAME
    $CHECKCOUNT
    $CHECKINTERVAL
    $CHECKTIMEOUT
    $CMD
    $CONFIG
    $DEBUG
    $FALLBACK
    $FIRSTHEALTHCHECK
    $HOSTNAME
    $L7D_TERM_CALLED
    $L7DIRECTORD
    $L7DIRLOG
    $L7VSADM
    $NEGOTIATETIMEOUT
    $QUIESCENT
    $RUNPID
    $SUPERVISED
    $SERVICE_UP
    $SERVICE_DOWN
    $VERSION

    $checksum
    $initializing
    $opt_d
    $opt_h
    $opt_t
    $pid
    $stattime

    @OLDVIRTUAL
    @REAL
    @VIRTUAL

    %L7D_INSTANCE
);

# current version
$VERSION = '2.0.0-1';

# default values
$AUTOCHECK        = "no";
$CHECKCOUNT       = 1;
$CHECKINTERVAL    = 10;
$CHECKTIMEOUT     = 5;
$CFGNAME          = "";
$FIRSTHEALTHCHECK = 1;

$SERVICE_UP   = 0;
$SERVICE_DOWN = 1;

# Commented out $CONNECTIMEOUT variable since it is not used - NTT COMWARE
#$CONNECTTIMEOUT   = 0;
$L7DIRECTORD      = "/usr/sbin/l7directord";      # path onto myself
$L7DIRLOG         = "/var/log/l7directord.log";
$L7D_TERM_CALLED  = 0;
$NEGOTIATETIMEOUT = 0;
$RUNPID           = "/var/run/l7directord";
$QUIESCENT        = "yes";

use Getopt::Long;
use Socket;
use Sys::Hostname;
use POSIX qw(setsid);
use Sys::Syslog qw(:DEFAULT setlogsock);

# command line options
my @OLD_ARGV = @ARGV;
GetOptions("debug" => \$opt_d, "help" => \$opt_h, "test:s" => \$opt_t);

$DEBUG = defined $opt_d ? 3 : 0;

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

# main code
if (defined $opt_h) {
    &system_wrapper("/usr/bin/perldoc -U $L7DIRECTORD");
}
elsif (defined $opt_t) {
    $CONFIG = 'l7directord.cf';
    if (-f $opt_t) {
        $CONFIG = $opt_t;
    }
    elsif ( -f "/etc/ha.d/$CONFIG" ) {
        $CONFIG = "/etc/ha.d/$CONFIG";
    }
    elsif ( -f "/etc/ha.d/conf/$CONFIG" ) {
        $CONFIG = "/etc/ha.d/conf/$CONFIG";
    }
    else {
        init_error("Config file $CONFIG not found");
    }
    $initializing = 1;
    read_config();
    print STDOUT "Syntax OK\n";
}
else {

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

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

# functions
sub ld_init {

    # install signal handlers (this covers TERM)
    #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  = "l7directord.cf";
        $CFGNAME = "l7directord";
        $CMD     = $ARGV[0];
    }
    if (    $CMD ne "start"
        and $CMD ne "stop"
        and $CMD ne "status"
        and $CMD ne "restart"
        and $CMD ne "try-restart"
        and $CMD ne "reload"
        and $CMD ne "force-reload" )
    {
        usage();
    }
    if ( -f "/etc/ha.d/$CONFIG" ) {
        $CONFIG = "/etc/ha.d/$CONFIG";
    }
    elsif ( -f "/etc/ha.d/conf/$CONFIG" ) {
        $CONFIG = "/etc/ha.d/conf/$CONFIG";
    }
    elsif ( !-f "$CONFIG" ) {
        init_error("Config file $CONFIG not found");
    }
    read_config();
    undef @OLDVIRTUAL;

    my $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 (/l7directord/) {
                $oldpid = $filepid;
            }
            close(FILE);
        }
    }
    if ( defined $oldpid ) {
        if ( $CMD eq "start" ) {
            ld_exit( 0, "Exiting from l7directord $CMD" );
        }
        elsif ( $CMD eq "stop" ) {
            kill 15, $oldpid;
            ld_exit( 0, "Exiting from l7directord $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 l7directord $CMD" );
        }
        else {    # status
            print STDERR
                "l7directord for $CONFIG is running with pid: $oldpid\n";
            ld_cmd_children( "status", %L7D_INSTANCE );
            ld_log("l7directord for $CONFIG is running with pid: $oldpid");
            ld_log("Exiting from l7directord $CMD");
            ld_exit( 0, "Exiting from l7directord $CMD" );
        }
    }
    else {
        if ( $CMD eq "start" or $CMD eq "restart" ) {
            ;
        }
        elsif ( $CMD eq "stop" or $CMD eq "try-restart" ) {
            ld_exit( 0, "Exiting from l7directord $CMD" );
        }
        elsif ( $CMD eq "status" ) {
            my $status;
            if ( defined $filepid ) {
                print STDERR "l7directord stale pid file "
                    . "$RUNPID.$CFGNAME.pid for $CONFIG\n";
                ld_log(   "l7directord stale pid file "
                        . "$RUNPID.$CFGNAME.pid for $CONFIG" );
                $status = 1;
            }
            else {
                $status = 3;
            }
            print STDERR "l7directord is stopped for $CONFIG\n";
            ld_log("l7directord is stopped for $CONFIG");
            ld_exit( $status, "Exiting from l7directord $CMD" );
        }
        else {
            ld_log("l7directord is stopped for $CONFIG");
            ld_exit( 1, "Exiting from l7directord $CMD" );
        }
    }

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

sub usage {
    init_error( "Usage l7directord [-d] [configfile] "
            . "\{start|stop|restart|try-restart|reload|force-reload|"
            . "status\}\n"
            . "Type l7directord -h for more information" );
}

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

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

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

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

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

sub read_config {
    undef @VIRTUAL;
    undef @REAL;
    undef $CALLBACK;
    undef %L7D_INSTANCE;
    undef $checksum;
    $SUPERVISED = 0;
    $stattime   = 0;

   # Commented out Duplicate virtual service check. Not required - NTT COMWARE
   #my %virtual_seen;
    open( CFGFILE, "<$CONFIG" )
        or &config_error( 0, "can not open file $CONFIG" );
    my $line = 0;
    while (<CFGFILE>) {
        $line++;
    outer_loop:
        if ( $_ =~ /^virtual\s*=\s*(.*)/ ) {
            my $vattr   = $1;
            my $ip_port = undef;

   # Commented out fwm related program code since it is not used - NTT COMWARE
   #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";

   # Commented out fwm related program code since it is not used - NTT COMWARE
   #} elsif ($vattr =~ /^(\d+)/){
   #	$virtual_id = $fwm = $1;
            }
            else {
                &config_error( $line, "invalid address for virtual server" );
            }

   # Commented out Duplicate virtual service check. Not required - NTT COMWARE
   #if (defined $virtual_seen{$virtual_id}) {
   #	&config_error($line,
   #		"duplicate virtual server");
   #}
   #$virtual_seen{$virtual_id} = 1;

            my ( %vsrv, @rsrv );
            if ($ip_port) {
                $vsrv{checktype} = "negotiate";
                $vsrv{protocol}  = "tcp";

     # Commented out code for udp, now even port 53 would be tcp - NTT COMWARE
     #if ($ip_port =~ /:53$/) {
     #	$vsrv{protocol} = "udp";
     #}
            }

         # Removed fwm related program code since it is not used - NTT COMWARE
         #} else {
         #        $vsrv{fwm} = $fwm;
         #	$vsrv{checktype} = "negotiate";
         #        $vsrv{protocol} = "fwm";
         #	$vsrv{service} = "none";
         #	$vsrv{port} = "0";
         #}
            $vsrv{real} = \@rsrv;

            # Changed default scheduler to rr instead of wrr - NTT COMWARE
            #$vsrv{scheduler} = "wrr";
            $vsrv{scheduler}    = "rr";
            $vsrv{request}      = "/";
            $vsrv{receive}      = "";
            $vsrv{login}        = "";
            $vsrv{passwd}       = "";
            $vsrv{database}     = "";
            $vsrv{checktimeout} = 0;

# Commented out connecttimeout related variables since it is not used - NTT COMWARE
#$vsrv{connecttimeout} = 0;
            $vsrv{checkcount}       = 0;
            $vsrv{negotiatetimeout} = 0;
            $vsrv{num_connects}     = 0;
            $vsrv{httpmethod}       = "GET";

            # Added default sorry_id/max_conn/qos_service/schedulerqos_clients
            # for virtual service edit - NTT COMWARE
            $vsrv{sorry_id}    = "0.0.0.0:0";
            $vsrv{max_conn}    = 0;
            $vsrv{qos_service} = 0;
            $vsrv{qos_clients} = 0;

            push( @VIRTUAL, \%vsrv );
            while (<CFGFILE>) {
                $line++;
                if (m/^\s*#/) {
                    next;
                }
                s/#.*//;
                s/\t/    /g;
                unless (/^ {4,}(.+)/) {
                    last;
                }
                my $rcmd = $1;
                if ( $rcmd =~ /^real\s*=\s*(.*)/ ) {
                    push @rsrv_todo, [ $1, $line ];
                }
                elsif ( $rcmd =~ /^request\s*=\s*\"(.*)\"/ ) {
                    $1 =~ /(.+)/
                        or
                        &config_error( $line, "no request string specified" );
                    $vsrv{request} = $1;
                    unless ( $vsrv{request} =~ /^\// ) {
                        $vsrv{request} = "/" . $vsrv{request};
                    }

                }
                elsif ( $rcmd =~ /^receive\s*=\s*\"(.*)\"/ ) {
                    $1 =~ /(.+)/
                        or &config_error( $line, "invalid receive string" );
                    $vsrv{receive} = $1;
                }
                elsif ( $rcmd =~ /^checktype\s*=\s*(.*)/ ) {
                    my $lc_checktype = lc($1);
                    if ( $lc_checktype =~ /(\d+)/ && $1 >= 0 ) {
                        $vsrv{num_connects} = $1;
                        $vsrv{checktype}    = "combined";
                    }
                    elsif (
                        $1 =~ /(\w+)/
                        && (   $1 eq "connect"
                            || $1 eq "negotiate"
                            || $1 eq "ping"
                            || $1 eq "off"
                            || $1 eq "on" )
                        )
                    {
                        $vsrv{checktype} = $1;
                    }
                    else {
                        &config_error( $line,
                            "checktype must be connect, negotiate, ping, off, on or a positive number"
                        );
                    }
                }
                elsif ( $rcmd =~ /^checktimeout\s*=\s*(.*)/ ) {
                    $1 =~ /(\d+)/ && $1
                        or &config_error( $line, "invalid check timeout" );
                    $vsrv{checktimeout} = $1;

# Commented out connectimeout since it is not used - NTT COMWARE
#} elsif ($rcmd =~ /^connecttimeout\s*=\s*(.*)/){
#         $1 =~ /(\d+)/ && $1 or &config_error($line, "invalid check timeout");
#         $vsrv{connecttimeout} = $1;
                }
                elsif ( $rcmd =~ /^negotiatetimeout\s*=\s*(.*)/ ) {
                    $1 =~ /(\d+)/ && $1
                        or
                        &config_error( $line, "invalid 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 =~ /^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;

   # Removed load related checks since it is not used - NTT COMWARE
   #} elsif ($rcmd =~ /^load\s*=\s*\"(.*)\"/) {
   #	$1 =~ /(\w+)/ or &config_error($line, "invalid string for load testing");
   #	$vsrv{load} = $1;
   #	lc($1);
                }
                elsif ( $rcmd =~ /^scheduler\s*=\s*(.*)/ ) {

# L4 ldirectord just checks whether the scheduler is any text string.
# But for l7vsadm, modified the scheduler check such that only lc or rr is allowed
# since l7vsadm supports only lc or rr scheduling - NTT COMWARE
#$1 =~ /([a-z]+)/
#    or &config_error($line, "invalid scheduler, should be only lowercase letters (a-z)");
                    ( $1 eq "lc" || $1 eq "rr" || $1 eq "wrr" )
                        or &config_error( $line,
                        "invalid scheduler, should be only lc, rr or wrr" );
                    $vsrv{scheduler} = $1;

# Removed persistent and netmask related checks and variables since it is not used - NTT COMWARE
#} elsif ($rcmd =~ /^persistent\s*=\s*(.*)/) {
#	$1 =~ /(\d+)/ or &config_error($line, "invalid persistent timeout");
#	$vsrv{persistent} = $1;
#} elsif ($rcmd =~ /^netmask\s*=\s*(.*)/) {
#	$1 =~ /(\d+\.\d+\.\d+\.\d+)/ or &config_error($line, "invalid netmask");
#	$vsrv{netmask} = $1;
                }
                elsif ( $rcmd =~ /^protocol\s*=\s*(.*)/ ) {
                    my $lc_protocol = lc($1);

# Removed fwm/udp related program code since it is not used - NTT COMWARE
#if ( $1 =~ /(\w+)/ ) {
#if ( $vsrv{protocol} eq "fwm" ) {
#	if ($1 eq "fwm" ) {
#		; #Do nothing, it is already set
#	} else {
#		&config_error($line, "protocol must be fwm if the virtual service is a fwmark (a number)");
#	}
#} else {    # tcp or udp
#	if ($1 eq "tcp" || $1 eq "udp") {
#		$vsrv{protocol} = $1;
#	} else {
#		&config_error($line, "protocol must be tcp or udp if the virtual service is an address and port");
#	}
#}
#} else {
#	&config_error($line, "invalid protocol");
#}
                    if ( $lc_protocol =~ /(\w+)/ ) {
                        if ( $1 eq "tcp" ) {
                            $vsrv{protocol} = $1;
                        }
                        else {
                            &config_error( $line,
                                "invalid protocol. protocol must be tcp" );
                        }
                    }
                }
                elsif ( $rcmd =~ /^service\s*=\s*(.*)/ ) {
                    my $lc_service = lc($1);
                    $lc_service =~ /(\w+)/ && ( $1 eq "http"
                        || $1 eq "https"
                        || $1 eq "ldap"
                        || $1 eq "ftp"
                        || $1 eq "none"
                        || $1 eq "smtp"
                        || $1 eq "pop"
                        || $1 eq "imap"
                        || $1 eq "nntp"
                        || $1 eq "dns"
                        || $1 eq "mysql"
                        || $1 eq "pgsql"
                        || $1 eq "sip" )
                        or &config_error(
                        $line,
                        "service must be http, https, ftp, smtp, pop, imap, ldap, nntp, dns, mysql, pgsql, sip, or none"
                        );
                    $vsrv{service} = $1;
                    if (    $vsrv{service} eq "ftp"
                        and $vsrv{login} eq "" )
                    {
                        $vsrv{login} = "anonymous";
                    }
                    elsif ( $vsrv{service} eq "sip"
                        and $vsrv{login} eq "" )
                    {
                        $vsrv{login} = "l7directord\@$HOSTNAME";
                    }
                    if (    $vsrv{service} eq "ftp"
                        and $vsrv{passwd} eq "" )
                    {
                        $vsrv{passwd} = "l7directord\@$HOSTNAME";
                    }
                }
                elsif ( $rcmd =~ /^httpmethod\s*=\s*(.*)/ ) {
                    $1 =~ /(\w+)/ && ( uc($1) eq "GET" || uc($1) eq "HEAD" )
                        or &config_error( $line,
                        "httpmethod must be GET or HEAD" );
                    $vsrv{httpmethod} = uc($1);
                }
                elsif ( $rcmd =~ /^virtualhost\s*=\s*(.*)/ ) {
                    $1 =~ /\"?([^\"]*)\"?/
                        or &config_error( $line, "invalid virtualhost" );
                    $vsrv{virtualhost} = $1;
                }
                elsif ( $rcmd =~ /^fallback\s*=\s*(.*)/ )
                {    # Allow specification of a virtual-specific fallback host
                    $fallback_line = $line;
                    $vsrv{fallback} = parse_fallback( $line, $1 );
                }
                elsif ( $rcmd =~ /^quiescent\s*=\s*(.*)/ ) {
                    ( $1 eq "yes" || $1 eq "no" )
                        or &config_error( $line,
                        "quiescent must be 'yes' or 'no'" );
                    $vsrv{quiescent} = $1;

# Added the module part of the code for l7vsadm - NTT COMWARE
# This check is valid, when the read line starts with "module" as the character string
                }
                elsif ( $rcmd =~ /^module\s*=\s*(.*)/ ) {
                    $1 =~ /(.+)/
                        or &config_error( $line, "No module is specified" );
                    $vsrv{module} = $1;

# Translate the " character into ' character. This will be useful for triggering l7vsadm
# Even if the user inputs " character it will be taken as the ' character
                    $vsrv{module} =~ tr/"/'/d;

 # "Added code for getting the key values of the virtual service - NTT COMWARE
 # module key is a vital part in uniquely identifying the virtual service.
                    my $module     = $vsrv{module};
                    my $module_key = '';
                    if ((   $module =~ /^(pfilter).*?( --path-match\s+[^\s]+)/
                        )
                        || ( $module
                            =~ /^(url).*?( --pattern-match\s+[^\s]+)/ )
                        || ( $module =~ /^(urla).*?( --key-name\s+[^\s]+)/ )
                        || ( $module
                            =~ /^(cpassive|crewrite|cinsert|chash).*?( --cookie-name\s+[^\s]+)/
                        )
                        || ( $module =~ /^(sessionless|sslid)()/ )
                        )
                    {

# For pfilter, $module_key would be returned as "pfilter --path-match xxxx"
# For url, $module_key would be returned as "url --pattern-match xxxx"
# For urla, $module_key would be returned as "urla --key-name xxxx"
# For cpassive, $module_key would be returned as "cpassive --cookie-name xxxx"
# For crewrite, $module_key would be returned as "crewrite --cookie-name xxxx"
# For cinsert, $module_key would be returned as "cinsert --cookie-name xxxx"
# For chash, $module_key would be returned as "chash --cookie-name xxxx"
# For sessionless, $module_key would be returned as "sessionless"
# For sslid, $module_key would be returned as "sslid"

                        $module_key = $1 . $2;

           # Remove the single quote too for the module key. This will help in
           # the comparision of module key data.
           # l7vsadm does not output with the SINGLE QUOTE
                        $module_key =~ tr/'//d;
                    }
                    else {
                        &config_error( $line,
                            "module argument should be of pfilter or url or urla or cpassive or crewrite types"
                        );
                    }
                    $vsrv{module_key} = $module_key;

                   # Added sorry server related code for l7vsadm - NTT COMWARE
                }
                elsif ( $rcmd =~ /^sorryserver\s*=\s*(.*)/ ) {
                    my $sorry_attr = $1;
                    my $sorry_id;
                    if ( $sorry_attr
                        =~ /^(\d+\.\d+\.\d+\.\d+):([0-9A-Za-z]+)/ )
                    {
                        $sorry_id = "$1:$2";
                    }
                    elsif (
                        $sorry_attr =~ /^([0-9A-Za-z._+-]+):([0-9A-Za-z]+)/ )
                    {
                        $sorry_id = "$1:$2";
                    }
                    else {
                        &config_error( $line,
                            "invalid address for sorry server" );
                    }

                    $vsrv{sorry_id}
                        = &ld_gethostservbyname( $sorry_id, "tcp" );

                    if ( !defined( $vsrv{sorry_id} ) ) {
                        &config_error( $line,
                            "invalid address for sorry server" );
                    }

                 # Added max connection related code for l7vsadm - NTT COMWARE
                }
                elsif ( $rcmd =~ /^maxconn\s*=\s*(.*)/ ) {
                    $1 =~ /(\d+)/ && $1
                        or &config_error( $line,
                        "invalid maximum connection count" );
                    $vsrv{max_conn} = $1;

                }
                elsif ( $rcmd =~ /^qosservice\s*=\s*(.*)/ ) {
                    $1 =~ /(\d+[KMGkmg]?)/ && $1
                        or &config_error( $line,
                        "invalid QoS value for virtual service" );
                    $vsrv{qos_service} = $1;

                }
                elsif ( $rcmd =~ /^qosclients\s*=\s*(.*)/ ) {
                    $1 =~ /(\d+[KMGkmg]?)/ && $1
                        or &config_error( $line,
                        "invalid QoS value for client connections" );
                    $vsrv{qos_clients} = $1;
                }
                elsif ( $rcmd =~ /^realdowncallback\s*=\s*(.*)/ ) {
                    $1 =~ m{^(/.*[^/])$}
                        or &config_error( $line,
                        "invalid real server down shell" );
                    -x $1 
                        or &config_error( $line,
                        "real server down shell '$1' not found or is not executable" );
                    $vsrv{realdowncallback} = $1;
                }
                elsif ( $rcmd =~ /^realrecovercallback\s*=\s*(.*)/ ) {
                    $1 =~ m{^(/.*[^/])$}
                        or &config_error( $line,
                        "invalid real server recover shell");
                    -x $1 
                        or &config_error( $line,
                        "real server recover shell '$1' not found or is not executable" );
                    $vsrv{realrecovercallback} = $1;
                }
                else {
                    &config_error( $line, "Unknown command $_" );
                }
            }

            # As the protocol needs to be known to call
            # getservbyname() all resolution must be
            # delayed until the protocol is finalised.
            # That is after the entire configuration
            # for a virtual service has been parsed.

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

            last if not defined $_;

            #Arggh a goto :(
            goto outer_loop;
        }
        next if ( $_ =~ /^\s*$/ || $_ =~ /^\s*#/ );
        if ( $_ =~ /^checktimeout\s*=\s*(.*)/ ) {
            ( $1 =~ /(\d+)/ && $1 && $1 > 0 )
                or &config_error( $line, "invalid check timeout value" );
            $CHECKTIMEOUT = $1;

# Commented out connecttimeout related checks since it is not used - NTT COMWARE
#} elsif ($_ =~ /^connecttimeout\s*=\s*(.*)/) {
#	($1 =~ /(\d+)/ && $1 && $1>0) or &config_error($line,
#			"invalid timeout value");
#	$CONNECTTIMEOUT = $1;
        }
        elsif ( $_ =~ /^negotiatetimeout\s*=\s*(.*)/ ) {
            ( $1 =~ /(\d+)/ && $1 && $1 > 0 )
                or &config_error( $line, "invalid negotiate timeout value" );
            $NEGOTIATETIMEOUT = $1;
        }
        elsif ( $_ =~ /^checkinterval\s*=\s*(.*)/ ) {
            $1 =~ /(\d+)/ && $1
                or &config_error( $line, "invalid checkinterval value" );
            $CHECKINTERVAL = $1;
        }
        elsif ( $_ =~ /^checkcount\s*=\s*(.*)/ ) {
            $1 =~ /(\d+)/ && $1
                or &config_error( $line, "invalid checkcount value" );
            $CHECKCOUNT = $1;
        }
        elsif ( $_ =~ /^fallback\s*=\s*(.*)/ ) {
            my $tcp = &ld_gethostservbyname( $1, "tcp" );

           # Commented out udp related code since it is not used - NTT COMWARE
           #my $udp = &ld_gethostservbyname($1, "udp");
            my $tcp_fb;

            #my $udp_fb;
            #if(!defined($tcp) and !defined($udp)){
            #    &config_error($line,
            #    	"invalid address for fallback server");
            #}
            if ( !defined($tcp) ) {
                &config_error( $line, "invalid address for fallback server" );
            }
            else {
                $tcp_fb = &parse_fallback( $line, $tcp );
            }

            # Commented out udp related code since it is not used
            # tcp related code is added in the above ELSE loop - NTT COMWARE
            #if(defined($tcp)) {
            #        $tcp_fb=&parse_fallback($line, $tcp);
            #}
            #if(defined($udp)) {
            #        $udp_fb=&parse_fallback($line, $udp);
            #}
            #$FALLBACK = { "tcp" => $tcp_fb, "udp" => $udp_fb };
            $FALLBACK = { "tcp" => $tcp_fb };
        }
        elsif ( $_ =~ /^autoreload\s*=\s*(.*)/ ) {
            ( $1 eq "yes" || $1 eq "no" )
                or &config_error( $line, "autoreload must be 'yes' or 'no'" );
            $AUTOCHECK = $1;
        }
        elsif ( $_ =~ /^callback\s*=\s*\"(.*)\"/ ) {
            $CALLBACK = $1;
        }
        elsif ( $_ =~ /^logfile\s*=\s*\"(.*)\"/ ) {
            my $tmpL7DIRLOG = $L7DIRLOG;
            $L7DIRLOG = $1;
            if ( &ld_openlog() ) {
                $L7DIRLOG = $tmpL7DIRLOG;
                &config_error( $line, "unable to open logfile: $1" );
            }
        }
        elsif ( $_ =~ /^execute\s*=\s*(.*)/ ) {
            $L7D_INSTANCE{$1} = 1;
        }
        elsif ( $_ =~ /^supervised/ ) {
            $SUPERVISED = 1;
        }
        elsif ( $_ =~ /^quiescent\s*=\s*(.*)/ ) {
            ( $1 eq "yes" || $1 eq "no" )
                or &config_error( $line, "quiescent must be 'yes' or 'no'" );
            $QUIESCENT = $1;
        }
        else {

# Removed timeout related checks since timeout directive is long deprecated and it is not used - NTT COMWARE
#if ($_ =~ /^timeout\s*=\s*(.*)/) {
#	&config_error($line,
#			"timeout directive " .
#			"deprciated in favour of " .
#			"checktimeout, " .
#			"negotiatetimeout or " .
#			"connecttimeout");
#}
            &config_error( $line, "Unknown command $_" );
        }
    }
    close(CFGFILE);
    return (0);
}

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

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

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

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

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

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

    my $ip_port;

    unless ($fallback) {
        return;
    }

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

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

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

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

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

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

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

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

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

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

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

# add_real_server
# Add a real server to a virtual
# pre: line: line number real server was read from
#            Used for debugging information
#      vsrv: virtual server to add real server to
#      ip: IP address of real server
#      port: Port of real server
#      flags: Flags for real server. Should be of the form
#             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 };

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

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

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

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

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

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

    push( @$rsrv, $new_rsrv );

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

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

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

    my $ip_port;
    my $fwd;

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

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

# Removed gate/ipip part of the code since l7vsadm supports only masq - NTT COMWARE
# Also default for forwarding mechanism is made as masq
    if ($fwd) {

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

        #$fwd="gate"
        $fwd = "masq";
    }

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

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

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

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

sub ld_setup {
    for my $v (@VIRTUAL) {
        if ( $$v{protocol} eq "tcp" ) {
            $$v{proto} = "-t";
        }

     # Removed out udp and fwm related code since it is not used - NTT COMWARE
     #} elsif ($$v{protocol} eq "udp") {
     #	$$v{proto} = "-u";
     #} elsif ($$v{protocol} eq "fwm") {
     #	$$v{proto} = "-f";
     #}
        $$v{flags} = "$$v{proto} " . &get_virtual($v) . " ";

        # Added the module part as the flag for l7vsadm - NTT COMWARE
        $$v{flags} .= "-m $$v{module} ";

        $$v{flags} .= "-s $$v{scheduler} " if defined( $$v{scheduler} );

# Added the Sorry server and max connection related part for l7vsadm - NTT COMWARE
        if ( defined $$v{max_conn} ) {
            $$v{flags} .= "-u $$v{max_conn} ";
        }
        if ( defined $$v{sorry_id} ) {
            $$v{flags} .= "-b $$v{sorry_id} ";
        }
        if ( defined $$v{qos_service} ) {
            $$v{flags} .= "-Q $$v{qos_service} ";
        }
        if ( defined $$v{qos_clients} ) {
            $$v{flags} .= "-q $$v{qos_clients} ";
        }

# Removed persistent and netmask related flag setting since it is not used - NTT COMWARE
#if (defined $$v{persistent}) {
#	$$v{flags} .= "-p $$v{persistent} ";
#	$$v{flags} .= "-M $$v{netmask} " if defined ($$v{netmask});
#}

        my $real = $$v{real};
        for my $r (@$real) {

# Keeping the $$r{forw} as it is even though it is not used
# If this is removed then subsequently the calling parameters for sub-routines _restore_service
# and _remove_service have to be modified. By keeping this variable as it is, they can be kept
# the same for calling the above two sub-routines - NTT COMWARE
            $$r{forw} = get_forward_flag( $$r{forward} );

            if ( defined $$r{weight} ) {
                $$r{wght} = "$$r{weight}";
            }
            else {
                $$r{wght} = "1";
            }

            if ( defined $$r{request} && defined $$r{receive} ) {
                my $uri = $$r{request};
                $uri =~ s/^\///g;
                if ( $$r{request} =~ /$$v{service}:\/\// ) {
                    $$r{url} = "$uri";
                }
                else {
                    my $port = (
                        defined $$v{checkport} ? $$v{checkport} : $$r{port} );
                    $$r{url} = "$$v{service}:\/\/$$r{server}:$port\/$uri";
                }
            }
            else {
                my $uri = $$v{request};
                $uri =~ s/^\///g;
                my $port
                    = ( defined $$v{checkport} ? $$v{checkport} : $$r{port} );
                $$r{url} = "$$v{service}:\/\/$$r{server}:$port\/$uri";

                $$r{request} = $$v{request} unless defined $$r{request};
                $$r{receive} = $$v{receive};
            }
            if ( $$v{checktype} eq "combined" ) {
                $$r{num_connects} = 999999;
            }
            else {
                $$r{num_connects} = -1;
            }

            $$r{fail_counts} = 0;
        }
        $$v{checkcount}   = $CHECKCOUNT   if ( $$v{checkcount}   <= 0 );
        $$v{checktimeout} = $CHECKTIMEOUT if ( $$v{checktimeout} <= 0 );

# Removed connecttimeout related variables since it is not used (including $CONNECTIMEOUT) - NTT COMWARE
#$$v{connecttimeout} = $CONNECTTIMEOUT if ($$v{connecttimeout}<=0);
#$$v{connecttimeout} = $$v{checktimeout} if ($$v{connecttimeout}<=0);
        $$v{negotiatetimeout} = $NEGOTIATETIMEOUT
            if ( $$v{negotiatetimeout} <= 0 );
        $$v{negotiatetimeout} = $$v{checktimeout}
            if ( $$v{negotiatetimeout} <= 0 );
    }
}

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

# If the output of l7vsadm -K changes, then the output parsing of l7vsadm has to be done
# accordingly - NTT COMWARE

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

    # read status of current l7vsadm -K -n
    # -K indicates Key parameters of the module included.
    unless ( open( L7VS, "$L7VSADM -K -n |" ) ) {
        &ld_exit( -1, "Could not run $L7VSADM -K -n" );
    }
    $_ = <L7VS>;
    $_ = <L7VS>;
    $_ = <L7VS>;

    while (<L7VS>) {

# Commented out persistent and netmask related hash entries since it is not used.
# Added l7vsadm module directive that is also present in the output.
# Included the module as part of the $real_service in the hash - NTT COMWARE
#	if ($_ =~ /(\w+)\s+(\d+\.\d+\.\d+\.\d+\:\d+|\d+)\s+(\w+)\s+persistent\s+(\d+)\s+mask\s+(.*)/) {
#		$real_service = "$2 ".lc($1);
#		$oldsrv{"$real_service"} = {"real"=>{}, "scheduler"=>$3, "persistent"=>$4, "netmask"=>$5};
#	} elsif ($_ =~ /(\w+)\s+(\d+\.\d+\.\d+\.\d+\:\d+|\d+)\s+(\w+)\s+persistent\s+(\d+)/) {
#		$real_service = "$2 ".lc($1);
#		$oldsrv{"$real_service"} = {"real"=>{}, "scheduler"=>$3, "persistent"=>$4};
#	} elsif ($_ =~ /(\w+)\s+(\d+\.\d+\.\d+\.\d+\:\d+|\d+)\s+(\w+)/)
        if ( $_
            =~ /(\w+)\s+(\d+\.\d+\.\d+\.\d+\:\d+|\d+)\s+(\w+)\s+(\w+)\s+(\w+)\s*(.*)/
            )
        {

            # Added the module flag here. $3 indicates the module name
            # $6 indicates the module parameter key value - NTT COMWARE
            # For example, $3 can be pfilter and $6 can be --path-match xxxx
            $real_service = "$2 " . lc($1) . " $3" . " $6";
            $real_service =~ s/ +$//;
            $oldsrv{"$real_service"} = { "real" => {}, "scheduler" => $4 };
        }
        else {
            next;
        }
        while (<L7VS>) {
            last
                unless $_
                    =~ / ->\s+(\d+\.\d+\.\d+\.\d+\:\d+)\s+(\w+)\s+(\d+)/;

# Removed gate/ipip part of the code since l7vsadm supports only masq - NTT COMWARE
#if ($2 eq "Route") {
#	$fwd = "gate";
#} elsif ($2 eq "Tunnel") {
#	$fwd = "ipip";
#} elsif ($2 eq "Masq") {
#	$fwd = "masq";
#}
            if ( $2 eq "Masq" ) {
                $fwd = "masq";
            }
            $oldsrv{"$real_service"}->{"real"}->{"$1"}
                = { "forward" => $fwd, "weight" => $3 };
        }
        redo;
    }
    close(L7VS);

    return ( \%oldsrv );
}

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

    # read status of current l7vsadm -K -n
    $oldsrv = &ld_read_l7vsadm();

    # make sure virtual servers are up to date
    foreach $nv (@VIRTUAL) {

        # Added module key  to the check criteria - NTT COMWARE
        #my $real_service = &get_virtual($nv) . " "  . $nv->{protocol};
        my $real_service
            = &get_virtual($nv) . " "
            . $nv->{protocol} . " "
            . $nv->{module_key};

        if ( exists( $oldsrv->{"$real_service"} ) ) {

            # service exists, modify it
            &system_wrapper("$L7VSADM -E $$nv{flags}");

            #&ld_log("Changed virtual server: " . &get_virtual($nv));
            &ld_log(  "Changed virtual server: "
                    . &get_virtual($nv) . " "
                    . $nv->{module_key} );
        }
        else {

            # no such service, create a new one
            &system_wrapper("$L7VSADM -A $$nv{flags}");

            #&ld_log("Added virtual server: " . &get_virtual($nv));
            &ld_log(  "Added virtual server: "
                    . &get_virtual($nv) . " "
                    . $nv->{module_key} );
        }
    }

    # make sure real servers are up to date
    foreach $nv (@VIRTUAL) {
        my $nreal = $nv->{real};

        # Added module key to the check criteria - NTT COMWARE
        #my $ov = $oldsrv->{&get_virtual($nv) . " " . $nv->{protocol}};
        my $ov
            = $oldsrv->{ &get_virtual($nv) . " "
                . $nv->{protocol} . " "
                . $nv->{module_key} };
        my $or       = $ov->{real};
        my $fallback = fallback_find($nv);

        if ( defined($fallback) ) {
            delete( $or->{ $fallback->{server} } );
        }

        for $nr (@$nreal) {
            my $real_str = "$nr->{server}:$nr->{port}";
            if ( !defined( $or->{$real_str} )
                or $or->{$real_str}->{weight} == 0 )
            {
                $server_down->{$real_str} = [ $nv, $nr ];
            }
            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 ) {

            # Added module key to the criteria - NTT COMWARE
            &system_wrapper( "$L7VSADM -d "
                    . $nv->{proto} . " "
                    . &get_virtual($nv)
                    . " -m $nv->{module_key}"
                    . " -r $k" );

            #&get_virtual($nv) . " -r $k");
            &ld_log(  "Removed real server: $k (" . " x "
                    . &get_virtual($nv) . " "
                    . $nv->{module_key}
                    . ")\n" );

            #" x " .  &get_virtual($nv) . ")\n");
            delete( $$or{$k} );
        }

        # Added module key to the criteria - NTT COMWARE
        #delete($oldsrv->{&get_virtual($nv) . " " . $nv->{protocol}});
        delete(
            $oldsrv->{
                      &get_virtual($nv) . " "
                    . $nv->{protocol} . " "
                    . $nv->{module_key}
                }
        );
        &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) {

        # Added module key to the check criteria - NTT COMWARE
        if (!defined(
                $oldsrv->{
                          &get_virtual($nv) . " "
                        . $nv->{protocol}
                        . " $nv->{module_key}"
                    }
            )
            )
        {

            #$nv->{protocol}})) {
            next;
        }

        # service still exists, remove it
        # Added module key to the criteria - NTT COMWARE
        &system_wrapper( "$L7VSADM -D "
                . $nv->{proto} . " "
                . &get_virtual($nv)
                . " -m $nv->{module_key}" );

        #&get_virtual($nv));
        #&ld_log("Removed virtual server: " . &get_virtual($nv) . "\n");
        &ld_log(  "Removed virtual server: "
                . &get_virtual($nv) . " "
                . $nv->{module_key}
                . "\n" );
    }
}

sub ld_cmd_children {
    my ( $cmd, %children ) = (@_);

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

sub ld_stop {
    foreach my $v (@VIRTUAL) {
        my $virtual_id = get_virtual_id_str($v);
        my $real = $$v{real};
        foreach my $r (@$real) {
            if ( defined $r->{virtual_status}
                and exists $r->{virtual_status}->{"$virtual_id"}
                and $r->{virtual_status}->{"$virtual_id"} == $SERVICE_UP) {

# Added module key to the criteria - NTT COMWARE
#&system_wrapper("$L7VSADM -d $$v{proto} " . &get_virtual($v) . " -r $$r{server}:$$r{port}");
                &system_wrapper( "$L7VSADM -d $$v{proto} "
                        . &get_virtual($v)
                        . " -m $$v{module_key}"
                        . " -r $$r{server}:$$r{port}" );

                _status_down( $v, $r );
                &ld_log(
                          "Removed real server: "
                        . "$$r{server}:$$r{port} ("
                        .

                        #" x " . &get_virtual($v) );
                        " x "
                        . &get_virtual($v) . " "
                        . $v->{module_key} . " )"
                );
            }
        }

        # Added module key to the criteria - NTT COMWARE
        #&system_wrapper("$L7VSADM -D $$v{proto} " .  &get_virtual($v));
        &system_wrapper( "$L7VSADM -D $$v{proto} "
                . &get_virtual($v)
                . " -m $$v{module_key}" );

        #&ld_log("Removed virtual server: " .  &get_virtual($v));
        &ld_log(  "Removed virtual server: "
                . &get_virtual($v) . " "
                . $v->{module_key} );
    }
}

sub ld_main {

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

        REAL: foreach my $r (@$real) {
                my $real_id = get_real_id_str($r, $v);
                foreach my $tmp_id (@real_checked) {
                    if ( $real_id eq $tmp_id ) {
                        &ld_debug( 3,
                            "Already checked: real server=$real_id (virtual=$virtual_id)"
                        );
                        next REAL;
                    }
                }

                my $service_status = undef;
                my $current_status = get_status($v, $r);

                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") {
                        $service_status = check_http($v, $r);
                    }
                    elsif ($$v{service} eq "pop") {
                        $service_status = check_pop($v, $r);
                    }
                    elsif ($$v{service} eq "imap") {
                        $service_status = check_imap($v, $r);
                    }
                    elsif ($$v{service} eq "smtp") {
                        $service_status = check_smtp($v, $r);
                    }
                    elsif ($$v{service} eq "ftp") {
                        $service_status = check_ftp($v, $r);
                    }
                    elsif ($$v{service} eq "ldap") {
                        $service_status = check_ldap($v, $r);
                    }
                    elsif ($$v{service} eq "nntp") {
                        $service_status = check_nntp($v, $r);
                    }
                    elsif ($$v{service} eq "dns") {
                        $service_status = check_dns($v, $r);
                    }
                    elsif ($$v{service} eq "sip") {
                        $service_status = check_sip($v, $r);
                    }
                    elsif ($$v{service} eq "mysql") {
                        $service_status = check_mysql($v, $r);
                    }
                    elsif ($$v{service} eq "pgsql") {
                        $service_status = check_pgsql($v, $r);
                    }
                    else {
                        $service_status = check_none($v, $r);
                    }
                    $$r{num_connects} = 0 if ($service_status == $SERVICE_UP);
                }
                elsif ($$v{checktype} eq "connect") {
                    if ($$v{protocol} ne "udp") {
                        &ld_debug( 2,
                            "Checking connect: real server=$real_id (virtual=$virtual_id)"
                        );
                        $service_status = check_connect($v, $r);
                    }
                    else {
                        &ld_debug( 2,
                            "Checking connect (ping): real server=$real_id (virtual=$virtual_id)"
                        );
                        $service_status = check_ping($v, $r);
                    }
                }
                elsif ($$v{checktype} eq "ping") {
                    &ld_debug( 2,
                        "Checking ping: real server=$real_id (virtual=$virtual_id)"
                    );
                    $service_status = check_ping($v, $r);
                }
                elsif ($$v{checktype} eq "off") {
                    &ld_debug( 2,
                        "Checking off: No real or fallback servers to be added\n"
                    );
                    $service_status = $SERVICE_DOWN;
                }
                elsif ($$v{checktype} eq "on") {
                    &ld_debug( 2,
                        "Checking on: Real servers are added without any checks\n"
                    );
                    $service_status = $SERVICE_UP;
                }
                elsif ($$v{checktype} eq "combined") {
                    &ld_debug( 2,
                        "Checking combined-connect: real server=$real_id (virtual=$virtual_id)"
                    );
                    $service_status = check_connect($v, $r);
                    if ($service_status == $SERVICE_UP) {
                        $$r{num_connects}++;
                    }
                    else {
                        $$r{num_connects} = 999999;
                    }
                }

                if ($service_status == $SERVICE_DOWN and $current_status == $SERVICE_UP) {
                    $$r{fail_counts}++;
                    if ($$r{fail_counts} >= $$v{checkcount}) {
                        service_set($v, $r, "down");
                        $$r{fail_counts} = 0;
                    }
                }
                if ($service_status == $SERVICE_UP and $current_status == $SERVICE_DOWN) {
                    service_set($v, $r, "up");
                    $$r{fail_counts} = 0;
                }

                push(@real_checked, $real_id);
            }
        }

        $FIRSTHEALTHCHECK = 0;

        if (!check_cfgfile()) {
            sleep $CHECKINTERVAL;
        }
    }
}

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

    $$r{url} =~ /http:\/\/([^:\/]+)(:([^\/]+))?(\/.*)/;
    my $host = $1;

    #my $port = $3;
    my $uri = $4;
    my $virtualhost = ( defined $$v{virtualhost} ? $$v{virtualhost} : $host );

    &ld_debug( 2,
        "check_http: url=\"$$r{url}\" " . "virtualhost=\"$virtualhost\"" );

    my $ua = new LWP::UserAgent();
    $ua->timeout( $$v{negotiatetimeout} );
    my $h = new HTTP::Headers( "Host" => $virtualhost );
    my $req = new HTTP::Request( "$$v{httpmethod}", "$$r{url}", $h );
    my $res;
    {

        # LWP makes ungaurded calls to eval
        # which throw a fatal exception if they fail
        # Needless to say, this is completely stupid.
        local $SIG{'__DIE__'} = "DEFAULT";
        $res = $ua->request($req);
    }

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

    my $recstr = $$r{receive};
    if ($res->is_success
        && ( !( $recstr =~ /.+/ )
            || $res->content =~ /$recstr/ )
        )
    {
        &ld_debug( 2, "check_http: $$r{url} is up\n" );
        return $SERVICE_UP;
    }

    &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 = ( defined $$v{checkport} ? $$v{checkport} : $$r{port} );

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

    my $smtp = new Net::SMTP(
        $$r{server},
        Port    => $port,
        Timeout => $$v{negotiatetimeout}
    );
    if ($smtp) {
        $smtp->quit;
        return $SERVICE_UP;
    }
    else {
        return $SERVICE_DOWN;
    }
}

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

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

    my $pop = new Net::POP3(
        $$r{server},
        Port    => $port,
        Timeout => $$v{negotiatetimeout}
    );
    if ( !$pop ) {
        return $SERVICE_DOWN;
    }

    if ( $$v{login} ne "" ) {
        $pop->user( $$v{login} );
        my $num = $pop->pass( $$v{passwd} );
        if ( !defined($num) ) {
            $pop->quit();
            return $SERVICE_DOWN;
        }
    }

    $pop->quit();
    return $SERVICE_UP;
}

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

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

    my $imap = new Mail::IMAPClient(
        Server   => $$r{server},
        Port     => $port,
        Timeout  => $$v{negotiatetimeout},
        User     => $$v{login},
        Password => $$v{passwd}
    );
    if ( !$imap ) {
        return $SERVICE_DOWN;
    }

    if ( $$v{login} ne "" ) {
        my $authres = $imap->login();
        $imap->logout();
        if ( !$authres ) {
            return $SERVICE_DOWN;
        }
    }

    $imap->logout();
    return $SERVICE_UP;
}

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

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

    my $recstr = $$r{receive};
    my $ldap   = Net::LDAP->new(
        "$$r{server}",
        port    => $port,
        timeout => $$v{negotiatetimeout}
    );
    if ( !$ldap ) {
        &ld_debug( 4, "Connection failed" );
        return $SERVICE_DOWN;
    }

    my $mesg = $ldap->bind;
    if ( $mesg->is_error ) {
        &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 ) {
        &ld_debug( 2, "Count failed : " . $result->count );
        return $SERVICE_DOWN;
    }

    my $href       = $result->as_struct;
    my @arrayOfDNs = keys %$href;
    $recstr = $$r{receive};
    if ( !( $recstr =~ /.+/ ) || $arrayOfDNs[0] =~ /$recstr/ ) {
        return $SERVICE_UP;
    }
    else {
        &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 = ( defined $$v{checkport} ? $$v{checkport} : $$r{port} );
    my $status = 1;

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

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

    return $status;
}

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

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

sub check_sql {
    require DBI;
    my ( $v, $r, $dbd, $dbname ) = @_;
    my $port = ( defined $$v{checkport} ? $$v{checkport} : $$r{port} );
    my ( $dbh, $sth, $query, $rows, $result );    # Local variables
    $query = $$r{request};
    $query =~ s#^/##;
    unless ( $$v{login} && $query ) {
        &ld_log(
            "Error: Must specify a login and request string for mysql and postgresql checks. Not adding $$r{server}.\n"
        );
        return $SERVICE_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) {
        &ld_debug( 4, "Failed to bind to $$r{server} with $dbh->err" );
        return $SERVICE_DOWN;
    }
    $result--;
    $sth  = $dbh->prepare($query);
    $rows = $sth->execute;
    ld_debug( 4, "Database search returned $rows rows" );
    if ( $rows gt 0 ) {

        # If it returns with a number, it is ok.
        # Disallows query of an empty table.
        $result--;
    }

    # If user defined a receive string (number of rows returned), only do
    # the check if the previous fetchall_arrayref succeeded.
    #if (defined $$r{receive} && $result eq 0) {
    #	# Receive string specifies an exact number of rows
    #	if ($rows ne $$r{receive}) {
    #	ld_debug(2,"Service down, receive=$$r{receive}");
    #		$result=1;
    #	}
    #}
    if ( $result == 1 ) {
        # Should never get here
        return $SERVICE_DOWN;
    }
    $sth->finish;
    $dbh->disconnect;
    return $SERVICE_UP;
}

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

    eval {
        local $SIG{'__DIE__'} = "DEFAULT";
        local $SIG{'ALRM'} = sub { die "Timeout Alarm" };
        &ld_debug( 4, "Timeout is $$v{checktimeout}" );
        alarm $$v{checktimeout};
        my $sock = &ld_open_socket( $$r{server}, $port, $$v{protocol} );
        if ($sock) {
            close($sock);
        }
        else {
            alarm 0;    # Cancel the alarm
            die("Socket Connect Failed");
        }
        &ld_debug( 3, "Connected to $1 (port $port)" );
        alarm 0;        # Cancel the alarm
    };
    if ($@) {
        return $SERVICE_DOWN;
    }
    else {
        return $SERVICE_UP;
    }
}

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

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

    eval {
        use Socket;

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

        my $sock = &ld_open_socket( $$r{server}, $sip_d_port, $$v{protocol} );
        unless ($sock) {
            alarm 0;    # Cancel the alarm
            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 ($@) {
        return $SERVICE_DOWN;
    }
    else {
        return $SERVICE_UP;
    }
}

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

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

    open( TMP, '+>', undef );

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

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

    if ( $memory =~ /$$r{receive}/ ) {
        return $SERVICE_UP;
    }
    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{checktimeout} );
        $res->nameservers( $$r{server} );
        $query = $res->search($request);
        alarm(0);
    };

    if ( @$ eq "timeout\n" or !$query ) {
        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"} ) )
        {
            return $SERVICE_UP;
        }
    }
    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" );
    if ( $p->ping( $$r{server}, $$v{"checktimeout"} ) ) {
        &ld_debug( 2, "pong from $$r{server}\n" );
        return $SERVICE_UP;
    }
    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" );
    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);
        foreach $tmp_id (@$virtual) {
            if ( $virtual_id eq $tmp_id ) {
                $found = 1;
                last;
            }
        }
        if ( $found == 1 ) {
            if ( $state =~ /up/i ) {
                _service_up( $v, $r, $force );
                &ld_debug( 2, "Enabled server=$$r{server}" );
            }
            elsif ( $state =~ /down/i ) {
                _service_down( $v, $r, $force );
                &ld_debug( 2, "Disabled server=$$r{server}" );
            }
        }
    }
}

# _remove_service
# Remove a real server by either making it quiescent or deleteing it
# Should be called by _service_down or fallback_off
# I.e. If you want to change the state of a real server call service_set.
#      If you call this function directly then l7directord will lose track
#      of the state of real servers.
# If the real server exists (which it should) make it quiescent or
# delete it, depending on the global and per virtual service 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 tcp
#      rforw: Forwarding mechanism of service. Should be only "-m"
#	rforw is kept as it is, even though not used - NTT COMWARE
#      tag: Tag to use for logging. Should be either "real" or "fallback"
# post: real service is taken up from the respective virtual service
#       if it is inactive
# return: none

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

    my $oldsrv;
    my $ov;
    my $or;
    my $l7vsadm_args;
    my $log_args;
    my $virtual_str;

# Commented out the $old_service variable of the code since real server port is not
# made equal to the virtual server port - NTT COMWARE
#my $old_rservice;
    my $is_quiescent;

    $virtual_str = &get_virtual($v);

    $oldsrv = &ld_read_l7vsadm();

    # Added module key to the criteria - NTT COMWARE
    #$ov=$oldsrv->{$virtual_str . " " . $v->{"protocol"}};
    $ov
        = $oldsrv->{ $virtual_str . " "
            . $v->{"protocol"} . " "
            . $v->{module_key} };

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

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

    if (( !defined($or) and !defined($is_quiescent) )
        or (    defined($is_quiescent)
            and defined($or)
            and $or->{"weight"} eq 0
            and get_forward_flag( $or->{"forward"} ) eq $rforw
        )
        )
    {
        return;
    }

    # Added module key to the criteria - NTT COMWARE
    #$l7vsadm_args = "$$v{proto} " . $virtual_str . " -r $rservice";
    $l7vsadm_args
        = "$$v{proto} "
        . $virtual_str
        . " -m $$v{module_key}"
        . " -r $rservice";
    $log_args = "$tag server: $rservice ";

# Commented out the $old_service part of the code since anyway real server port is not
# made equal to the virtual server port - NTT COMWARE
#if(defined($old_rservice)) {
#	$log_args .= "mapped from $old_rservice "
#}

    # Added module key to the criteria - NTT COMWARE
    #$log_args .= "( x $virtual_str)";
    $log_args .= "( x $virtual_str $$v{module_key})";

    if ( defined($is_quiescent) ) {

        # Commented out the EDIT part for Real servers
        # Currently there is no edit functionality supported - NTT COMWARE
        if ( defined($or) ) {
            &system_wrapper("$L7VSADM -e $l7vsadm_args -w 0");
            &ld_log("Quiescent $log_args (Weight set to 0)");
        }
        else {
            &system_wrapper("$L7VSADM -a $l7vsadm_args -w 0");
            &ld_log("Quiescent $log_args (Weight set to 0)");
        }
    }
    else {
        &system_wrapper("$L7VSADM -d $l7vsadm_args");
        &ld_log("Deleted $log_args");
    }

    my $exec = $$v{realdowncallback};
    if ( defined( $exec ) and not defined( $force ) and !$FIRSTHEALTHCHECK ){
        &system_wrapper( "$exec $rservice" );
        &ld_log("real server down shell execute: $exec" );
    }
}

# _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 l7directord will lose track
#      of the state of real servers.
# If the real server exists (which it should) make it quiescent. If it
# doesn't exist, just leave it as it will be added by the _service_up code
# as appropriate.
# pre: v: reference to virtual service to with the real server belongs
#      rservice: service to restore. Of the form server:port for 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, $force ) = (@_);

    my $oldsrv;
    my $ov;
    my $or;
    my $l7vsadm_args;
    my $log_args;

    $l7vsadm_args
        = "$$v{proto} "
        . &get_virtual($v)
        . " -m $$v{module_key}"
        . " -r $rservice -w $rwght";

    $log_args
        = "$tag server: $rservice " . "( " #. scalar(%{$v->{real_status}})
                                           #. " x " .  &get_virtual($v) . ")";
        . " x " . &get_virtual($v) . " " . $$v{module_key} . " )";

    # If the server does not exist then add the server - NTT COMWARE
    $oldsrv = &ld_read_l7vsadm();

    # Added module key to the criteria - NTT COMWARE
    $ov
        = $oldsrv->{ &get_virtual($v) . " "
            . $v->{"protocol"} . " "
            . $v->{module_key} };

    #$ov=$oldsrv->{&get_virtual($v) . " " . $v->{"protocol"}};

# Added an extra return statement just in case virtual service is not present - NTT COMWARE
    if ( defined($ov) ) {
        $or = $ov->{"real"}->{$rservice};
    }
    else {
        return;
    }

    if ( defined($or) ) {
        unless ( $or->{"weight"} eq $rwght
            and get_forward_flag( $or->{"forward"} ) eq $rforw )
        {
            &system_wrapper("$L7VSADM -e $l7vsadm_args");
            &ld_log("Restored $log_args (Weight set to $rwght)");
        }
    }
    else {
        &system_wrapper("$L7VSADM -a $l7vsadm_args");
        &ld_log("Added $log_args (Weight set to $rwght)");
    }

    my $exec = $$v{realrecovercallback};
    if ( defined($exec) and not defined( $force ) and !$FIRSTHEALTHCHECK ){
        &system_wrapper("$exec $rservice");
        &ld_log("real server recovery shell execute: $exec");
    }

}

# 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 (get_status($v, $r, $is_fallback) == $SERVICE_UP) {
        return 0;
    }

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

    return 1;
}

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

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

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

    if (get_status($v, $r, $is_fallback) == $SERVICE_DOWN) {
        return 0;
    }

    if (defined($is_fallback)) {
        $v->{fallback_status}->{"$real_id"} = $SERVICE_DOWN;
    }
    else {
        $v->{real_status}->{"$real_id"} = $SERVICE_DOWN;
    }

    $r->{virtual_status}->{"$virtual_id"} = $SERVICE_DOWN;

    return 1;
}

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

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

    if (
        (defined($v->{real_status})
             and exists $v->{real_status}->{"$real_id"}
             and $v->{real_status}->{"$real_id"} == $SERVICE_UP)
        or
        (defined($is_fallback)
             and defined($v->{fallback_status})
             and exists $v->{fallback_status}->{"$real_id"}
             and $v->{fallback_status}->{"$real_id"} == $SERVICE_UP)
       )
    {
        return $SERVICE_UP;
    }
    return $SERVICE_DOWN;
}

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

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

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

    &_restore_service( $v, $r->{server} . ":" . $r->{port},
        $r->{forw}, $r->{wght}, "real", $force );
    &fallback_off($v);
}

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

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

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

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

    &fallback_on($v);
}

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

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

    my $fallback = &fallback_find($v);

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

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

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

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

    my $fallback = &fallback_find($v);

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

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

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

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

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

    return undef;
}

sub check_cfgfile {
    my ($dev, $ino,  $mode, $nlink, $uid,
        $gid, $rdev, $size, $atime, $mtime
    ) = stat($CONFIG);
    my ($status);
    return if ( $stattime == $mtime );
    $stattime = $mtime;
    use Digest::MD5 qw(md5 md5_hex);
    my $ctx = Digest::MD5->new;
    open( CFGFILE, "<$CONFIG" )
        || &config_error( 0, "can not open file $CONFIG" );
    $ctx->addfile(*CFGFILE);
    close(CFGFILE);
    my $digest = $ctx->hexdigest;

    if ( defined $checksum && $checksum ne $digest ) {
        &ld_log("Configuration file '$CONFIG' has changed on disk");
        if ( $AUTOCHECK eq "yes" ) {
            &ld_log(" - reread new configuration");
            &reread_config();
        }
        else {
            &ld_log(" - ignore new configuration\n");
        }
        if ( -x $CALLBACK ) {
            &system_wrapper("$CALLBACK $CONFIG");
        }
        $status = 1;
    }
    $checksum = $digest;

    return $status;
}

# ld_openlog
# Open logger
# make log rotation work
# pre: none
# post: If logger is a file, it opened and closed again as a test
#       If logger is syslog, it is opened so it can be used without
#       needing to be opened again.
#       Otherwiese, nothing is done.
# return: 0 on success
#         1 on error
sub ld_openlog {
    if ( defined $opt_d or $SUPERVISED ) {

        # Instantly do nothing
        return (0);
    }
    if ( $L7DIRLOG =~ /^\/(.*)/ ) {

        # Open and close the file as a test.
        # We open the file each time we want to log to it
        unless ( open( LOGFILE, ">>$L7DIRLOG" ) and close(LOGFILE) ) {
            return $SERVICE_DOWN;
        }
    }
    else {

        # Assume L7DIRLOG is a logfacility, log to syslog
        setlogsock("unix");
        openlog( "l7directord", "pid", "$L7DIRLOG" );
    }
    return (0);
}

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

    my $now = localtime();

    &ld_debug( 2, $message );
    chomp $message;
    if ( defined $opt_d ) {
        print STDERR "$message\n";
    }
    elsif ($SUPERVISED) {
        print "[$now] $message\n";
    }
    elsif ( $L7DIRLOG =~ /^\/(.*)/ ) {
        unless (open( LOGFILE, ">>$L7DIRLOG" )
            and print LOGFILE "[$now|$CFGNAME] $message\n"
            and close(LOGFILE) )
        {
            print STDERR "$message\n";
            return $SERVICE_DOWN;
        }
    }
    else {

        # Assume L7DIRLOG is a logfacility, log to syslog
        syslog( "info", "$message" );
    }
    return (0);
}

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

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

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

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

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

    my $status;

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

    return ($status);
}

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

    # Removed out fwm related code since it is not used - NTT COMWARE
    #if ($nv->{"protocol"} eq "fwm"){
    #	return $nv->{"fwm"};
    #} else {
    #	return $nv->{"server"} . ":" . $nv->{"port"};
    #}
    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 $check;
    my $real;

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

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

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

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

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

        #. $checkport . ":"
        . quotemeta($request) . ":" . quotemeta($receive);
}

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

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

    # Added module key to the criteria - NTT COMWARE
    #my $virtual = $v->{"protocol"} . ":" .  &get_virtual($v);
    my $virtual
        = $v->{"protocol"} . ":" . &get_virtual($v) . ":" . $v->{module_key};
}

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

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

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

    if ( $forward eq "masq" ) {
        return ("-m");
    }

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

    return (" ");
}

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

sub ld_exit {
    my ( $exit_status, $message ) = (@_);
    unless ( defined($exit_status) ) { $exit_status = 0; }
    unless ( defined($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.
    if ( open( STDIN, "</dev/null" ) < 0 ) {
        &ld_exit( 1, "ld_daemon: Could not open /dev/null" );
    }
    if ( open( STDOUT, ">>/dev/console" ) < 0 ) {
        &ld_exit( -1, "ld_daemon: Could not open /dev/console" );
    }
    if ( open( STDERR, ">>/dev/console" ) < 0 ) {
        &ld_exit( -1, "ld_daemon: Could not open /dev/console" );
    }
}

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

sub ld_daemon_become_child {
    my ($status);

    $status = fork();

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

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

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

    my @host = gethostbyname($name);

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

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

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

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

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

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

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

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

    my $ip;
    my $port;

    $hostserv =~ /(\d+\.\d+\.\d+\.\d+|[A-Za-z0-9.-]+)(:(\d+|[A-Za-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);
}

1;

__END__

=head1 NAME

l7directord - Linux Director Daemon

Daemon to monitor remote services and control Linux Virtual Server


=head1 SYNOPSIS

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


=head1 DESCRIPTION

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

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

to start l7directord from heartbeat.


=head1 OPTIONS

=over

=item I<configuration>:

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

=item B<-d>

Don't start as daemon. Useful for debugging.

=item B<-h>

Help. Print user manual of l7directord.

=item B<start>

Start the daemon for the specified configuration.

=item B<stop>

Stop the daemon for the specified configuration. This is the same as sending
a TERM signal to the running daemon.

=item B<restart>

Restart the daemon for the specified configuration. The same as stopping and starting.

=item B<try-restart>

Try to restart the daemon for the specified configuration. If l7directord is already running for the
specified configuration, then the same is stopped and started (Similar to restart).
However, if l7directord is not already running for the specified configuration, then an error message
is thrown and the program exits.

=item B<reload>

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.

=item B<force-reload>

Force reload the configuration file. Identical to B<reload>.

=item B<status>

Show status of the running daemon for the specified configuration.

=back


=head1 SYNTAX

=head2 Description how to write configuration files

=over

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

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

=item B<checktimeout = >I<n>

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

=item B<negotiatetimeout = >I<n>

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

=item B<checkinterval = >I<n>

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

=item B<checkcount = >I<n>

The number of times a check will be attempted before it is considered
to have failed. Note that the checktimeout is additive, so if checkcount
is 3 and checktimeout is 2 seconds, then a total of 6 seconds worth of
timeout will occur before the check fails. Default is 1. If defined in
virtual server section then the global value is overridden.

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

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

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

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

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

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

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

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

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

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

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

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

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

=item B<supervised>

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

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

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

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

=back


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

=over

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

Defines a real service by IP-address (or hostname) and port (or
servicename). If the port is omitted then a 0 will be used.
Optionally a range of IP addresses (or two hostnames) may be
given, in which case each IP address in the range will be treated as a real
server using the given port. The second argument defines the forwarding
method, it must be B<masq> only.  The third argument defines the weight of
each real service. This argument is optional. Default is 1. The last two
arguments are optional too. 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.

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

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

=back

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

=over

=item B<maxconn => I<n>

Defines the maximum connection that the virtual service can handle. If the number of
requests cross the maxconn limit, the requests would be redirected to the
sorry server.

=item B<qosservice => I<n>[B<K>|B<M>|B<G>]

Defines the bandwidth quota size in bps per virtual service. If the number of the
virtual service bandwidth is over the qosservice limit, a packet from/to the
virtual service will be delayed until the number of virtual service bandwidth
become below the qosservice limit. B<K>(kilo), B<M>(mega) and B<G>(giga) unit
are available.

=item B<qosclient => I<n>[B<K>|B<M>|B<G>]

Defines the bandwidth quota size in bps per client. If the number of the client
bandwidth is over the qosclient limit, a packet from/to the client will be
delayed until the number of client bandwidth become below the qosclient limit.
B<K>(kilo), B<M>(mega) and B<G>(giga) unit are available.

=item B<sorryserver =>I<ip_address|hostname[:portnumber|servicename]>

Defines a sorry server by IP-address (or hostname) and port (or
servicename). Firewall-mark settings cannot be set.
If the number of requests to the virtual service cross the maxconn limit, the requests would be
redirected to the sorry server.

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

Type of check to perform. Negotiate sends a request and matches a receive
string. Connect only attempts to make a TCP/IP connection, thus the
request and receive strings may be omitted.  If checktype is a number then
negotiate and connect is combined so that after each N connect attempts one
negotiate attempt is performed. This is useful to check often if a service
answers and in much longer intervals a negotiating check is done. 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>.

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

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

=item B<checkport = >I<n>

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

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

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

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

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

=item 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.

=item 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.

=item 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.

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

Username to use to login to FTP, POP, IMAP, MySQL and PostgreSQL servers.
For FTP, the default is anonymous. For POP and IMAP, the default is the
empty string, in which case authentication will not be attempted.
For a MySQL and PostgreSQL, the username must be provided.

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

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

Password to use to login to FTP, POP, IMAP, MySQL and PostgreSQL servers.
Default is for FTP is l7directord\@<hostname>, where hostname is the
environment variable HOSTNAME evaluated at run time, or sourced from uname
if unset. The default for all other services is an empty password, in the
case of MySQL and PostgreSQL this means authentication will not be
performed.

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

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

=item B<scheduler => I<scheduler_name>

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

=item B<protocol = tcp>

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

=item B<realdowncallback = ">I</path/to/realdowncallback>B<">

If this directive is defined, B<l7directord> automatically calls
the executable I</path/to/realdowncallback> after a real server's status
changes to down. The first argument to the realdowncallback is the real 
server's IP-address and port (ip_address:portnumber).

=item B<realrecovercallback = ">I</path/to/realrecovercallback>B<">

If this directive is defined, B<l7directord> automatically calls
the executable I</path/to/realrecovercallback> after a real server's status
changes to up. The first argument to the realrecovercallback is the real 
server's IP-address and port (ip_address:portnumber).

=back


=head1 FILES

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

B</var/log/l7directord.log>

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

B</etc/services>

=head1 SEE ALSO

L<l7vsadm>, L<heartbeat>


=head1 AUTHORS

NTT COMWARE

=cut
