#!/usr/bin/perl
######################################################################
# l7directord
# Linux Director Daemon - run "perldoc l7directord" for details
#
# 2005-2008 (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
#   2.1.0-0: Changed helthcheck logic to multi-process.
#            - 2008/12/17 NTT COMWARE
#   2.1.1-0: Fix 'Range iterator outside integer range' in parse_real.
#            - 2009/01/06 NTT COMWARE
#   2.1.2-0: Added code related to some module. See below.
#            (cpassive, crewrite, pfilter, url, ip)
#            Add custom healthcheck.
#            (checktype=custom, customcheck=exec_command)
#            - 2009/02/14 NTT COMWARE

use 5.006;
use strict;
use warnings;
use Getopt::Long qw(:config posix_default);
use Sys::Hostname;
use POSIX qw(:sys_wait_h :signal_h);
use Sys::Syslog qw(:DEFAULT setlogsock);
use English;
use Fatal qw(open close);
use Cwd qw(abs_path);
use Data::Dumper;
use Time::HiRes qw(sleep);
use IO::Handle;

# current version
our $VERSION     = '2.1.2-0';
our $COPYRIGHT   = 'Copyright (C) 2009 NTT COMWARE CORPORATION';

# default global config values
our %GLOBAL = (
    logfile          => '/var/log/l7vs/l7directord.log',
    autoreload       => 0,
    checkcount       => 1,
    checkinterval    => 10,
    retryinterval    => 10,
    configinterval   => 5,
    checktimeout     => 5,
    negotiatetimeout => 5,
    supervised       => 0,
    quiescent        => 1,
    virtual          => undef,
    execute          => undef,
    fallback         => undef,
    callback         => undef,
    );

# default virtual config values
our %VIRTUAL = (
    real                => undef,
    module              => { name => 'sessionless', key => q{} },
    scheduler           => 'rr',
    protocol            => 'tcp',
    checktype           => 'negotiate',
    service             => undef,
    checkport           => undef,
    maxconn             => 0,
    qosup               => 0,
    qosdown             => 0,
    sorryserver         => undef,
    request             => undef,
    receive             => undef,
    httpmethod          => 'GET',
    virtualhost         => undef,
    login               => q{},
    passwd              => q{},
    database            => q{},
    realdowncallback    => undef,
    realrecovercallback => undef,
    customcheck         => undef,
    # can override
    checkcount          => undef,
    checkinterval       => undef,
    retryinterval       => undef,
    checktimeout        => undef,
    negotiatetimeout    => undef,
    quiescent           => undef,
    fallback            => undef,
    );

# default real config values
our %REAL = (
    weight              => 1,
    forward             => 'masq',
    # can override
    request             => undef,
    receive             => undef,
    );

# current config data
our %CONFIG = %GLOBAL;

# config file data
our %CONFIG_FILE = (
    path            => undef,
    filename        => undef,
    checksum        => undef,
    stattime        => undef,
    );

# process environment
our %PROC_ENV = (
    l7directord => $0,
    l7vsadm     => undef,
    pid_prefix  => '/var/run/l7directord',
    hostname    => undef,
    );

# process status
our %PROC_STAT = (
    pid             => $PID,
    initialized     => 0,
    log_opened      => 0,
    health_checked  => 0,
    halt            => undef,
    reload          => undef,
    );

# debug level
our $DEBUG_LEVEL = 0;

# health check process data
our %HEALTH_CHECK  = ();

# real server health flag
our $SERVICE_UP   = 0;
our $SERVICE_DOWN = 1;

# section virtual sub config prefix
our $SECTION_VIRTUAL_PREFIX = "    ";

main();

# main
# Main method of this program.
# parse command line and run each command method.
sub main {
    my $cmd_func = {
        start         => \&cmd_start,
        stop          => \&cmd_stop,
        restart       => \&cmd_restart,
        'try-restart' => \&cmd_try_restart,
        reload        => \&cmd_reload,
        status        => \&cmd_status,
        configtest    => \&cmd_configtest,
        version       => \&cmd_version,
        help          => \&cmd_help,
        usage         => \&cmd_usage,
        };

    # change program name for removing `perl' string from `ps' command result.
    my $ps_name = @ARGV ? $PROGRAM_NAME . " @ARGV"
                        : $PROGRAM_NAME;
    $PROGRAM_NAME = $ps_name;

    my $cmd_mode = parse_cmd();
    if ( !defined $cmd_mode || !exists $cmd_func->{$cmd_mode} ) {
        $cmd_mode = 'usage';
    }
    if ($cmd_mode ne 'help' && $cmd_mode ne 'version' && $cmd_mode ne 'usage') {
        initial_setting();
    }

    # execute command.
    my $cmd_result = &{ $cmd_func->{$cmd_mode} }();

    ld_exit( $cmd_result, _message_only('INF0008') );
}

# parse_cmd
# Parse command line (ARGV)
sub parse_cmd {
    # configtest or help command
    my $cmd_mode = parse_option();

    # other command
    if (!defined $cmd_mode && @ARGV) {
        $cmd_mode = pop @ARGV;
    }
    return $cmd_mode;
}

# parse_option
# Parse option strings by Getopt::Long
sub parse_option {
    my $cmd_mode = undef;

    # default option value
    my $debug   = undef;
    my $help    = undef;
    my $test    = undef;
    my $version = undef;

    # parse command line options
    my $result = GetOptions(
        'd:3'       => \$debug,   # debug mode, arg: debug level (default 3)
        'h|help'    => \$help,    # show help message
        't'         => \$test,    # config syntax test
        'v|version' => \$version, # show version
        );

    if ($result) {
        # set debug level
        if (defined $debug) {
            $DEBUG_LEVEL = $debug;
        }

        # set command mode
        if (defined $help) {
            $cmd_mode = 'help';
        }
        elsif (defined $version) {
            $cmd_mode = 'version';
        }
        elsif (defined $test) {
            $cmd_mode = 'configtest';
        }
    }
    else {
        $cmd_mode = 'usage';
    }

    return $cmd_mode;
}

# initial_setting
# Initialize file path settings.
sub initial_setting {
    # search config and l7vsadm
    $PROC_ENV{l7vsadm} = search_l7vsadm_file();
    $CONFIG_FILE{path} = search_config_file();

    # get config file name exclude `.cf' or `.conf'
    ( $CONFIG_FILE{filename} )
        = $CONFIG_FILE{path} =~ m{([^/]+?)(?:\.cf|\.conf)?$};

    # get hostname
    $PROC_ENV{hostname}
        = defined $ENV{HOSTNAME} ? $ENV{HOSTNAME}
        :                          ( POSIX::uname() )[1]
        ;
}

# search_config_file
# Search l7directord.cf file from search path.
sub search_config_file {
    my $config_file = undef;
    my @search_path = qw(
        ./l7directord.cf
        /etc/ha.d/l7directord.cf
        /etc/ha.d/conf/l7directord.cf
        );

    if (@ARGV) {
        $config_file = $ARGV[0];
        if (!-f $ARGV[0]) {
            init_error( _message_only('ERR0404', $config_file) );
        }
    }
    else {
        for my $file (@search_path) {
            if (-f $file) {
                $config_file = $file;
                last;
            }
        }
        if (!defined $config_file) {
            init_error( _message_only('ERR0405', $config_file) );
        }
    }

    return abs_path($config_file);
}

# search_l7vsadm_file
# Search l7vsadm file from search path.
sub search_l7vsadm_file {
    my $l7vsadm_file = undef;
    my @search_path = qw(
        ./l7vsadm
        /usr/sbin/l7vsadm
        /sbin/l7vsadm
        );

    for my $file (@search_path) {
        if (-x $file) {
            $l7vsadm_file = $file;
            last;
        }
    }
    if (!defined $l7vsadm_file) {
        init_error( _message_only('ERR0406', $l7vsadm_file) );
    }

    return abs_path($l7vsadm_file);
}

# cmd_start
# Start process
# Called if command argument is start
# return: 0 if success
#         1 if old process id is found.
sub cmd_start {
    set_ld_handler();
    read_config();

    ld_log( _message('INF0001', $PROGRAM_NAME) );

    ld_setup();

    my $oldpid = read_pid();

    # already other process is running
    if ($oldpid) {
        print {*STDERR} _message_only('INF0103', $oldpid) . "\n";
        return 1;
    }
    
    # supervised or debug mode (not daemon)
    if ($CONFIG{supervised} || $DEBUG_LEVEL > 0) {
        ld_log( _message( 'INF0002', $VERSION, $PID, $CONFIG_FILE{path} ) );
    }
    # otherwise (daemon)
    else {
        ld_daemon();
        ld_log( _message( 'INF0003', $VERSION, $CONFIG_FILE{path} ) );
    }

    write_pid( $PROC_STAT{pid} );
    ld_cmd_children('start');
    ld_main();
    ld_cmd_children('stop');
    remove_pid();

    return 0;
}

# cmd_stop
# Send stop signal (TERM)
# Called if command argument is stop
# return: 0 if success
#         2 if old process id is not found.
#         3 if signal failed.
sub cmd_stop {
    my ($oldpid, $stalepid) = read_pid();

    # process is not running
    if (!$oldpid) {
        if ($stalepid) {
            my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
            print {*STDERR} _message_only('INF0102', $pid_file, $CONFIG_FILE{path}) . "\n";
        }
        print {*STDERR} _message_only('INF0104') . "\n";
        return 2;
    }

    # signal TERM
    my $signaled = kill 15, $oldpid;
    if ($signaled != 1) {
        print {*STDERR} _message('WRN0003', $oldpid);
        return 3;
    }
    return 0;
}

# cmd_restart
# Restart process
# Called if command argument is try-restart
# return: see cmd_start return
sub cmd_restart {
    # stop and ignore result
    cmd_stop();

    # wait for pid file
    sleep 1;

    # start
    my $status = cmd_start();

    return $status;
}

# cmd_try_restart
# Trying restart process
# Called if command argument is try-restart
# return: see cmd_start, cmd_stop return
sub cmd_try_restart {
    # stop
    my $stop_result = cmd_stop();

    # start only if stop succeed
    if ($stop_result != 0) {
        return $stop_result;
    }

    # wait for pid file
    sleep 1;

    # start
    my $status = cmd_start();

    return $status;
}

# cmd_reload
# Send reload signal (HUP)
# Called if command argument is reload
# return: 0 if success
#         2 if old process id is not found.
#         3 if signal failed.
sub cmd_reload {
    read_config();
    my ($oldpid, $stalepid) = read_pid();
    if (!$oldpid) {
        if ($stalepid) {
            my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
            print {*STDERR} _message_only( 'INF0102', $pid_file, $CONFIG_FILE{path} ) . "\n";
        }
        print {*STDERR} _message_only('INF0104') . "\n";
        return 2;
    }

    # signal HUP
    my $signaled = kill 1, $oldpid;
    if ($signaled != 1) {
        print {*STDERR} _message('WRN0004', $oldpid);
        return 3;
    }
    return 0;
}

# cmd_status
# Show process id of running
# Called if command argument is status
# return: 0 if success
#         2 if old process id is not found.
sub cmd_status {
    my ($oldpid, $stalepid) = read_pid();
    if (!$oldpid) {
        if ($stalepid) {
            my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
            print {*STDERR} _message_only('INF0102', $pid_file, $CONFIG_FILE{path}) . "\n";
        }
        print {*STDERR} _message_only('INF0104') . "\n";
        ld_cmd_children('status');

        return 2;
    }

    print {*STDERR} _message_only('INF0101', $CONFIG_FILE{path}, $oldpid) . "\n";

    read_config();
    ld_cmd_children('status');

    return 0;
}

# cmd_version
# Configuration syntax check
# Called if command argument is configtest
# return: 0 if syntax ok
#         otherwise, exit by read_config
sub cmd_configtest {
    read_config();
    print {*STDOUT} "Syntax OK\n";
    return 0;
}

# cmd_version
# Show program version.
# Called if command argument is version
# return: 0
sub cmd_version {
    print {*STDOUT} "l7directord, version $VERSION\n$COPYRIGHT\n";
    return 0;
}

# cmd_help
# Show command manual.
# Called if command argument is help
# return: 0
sub cmd_help {
    system_wrapper( '/usr/bin/perldoc ' . $PROC_ENV{l7directord} );
    return 0;
}

# cmd_usage
# Show command usage.
# Called if command argument is unknown or not specified.
# return: 0
sub cmd_usage {
    print {*STDERR} 
        "Usage: l7directord {start|stop|restart|try-restart|reload|status|configtest}\n"
      . "Try `l7directord --help' for more information.\n";
    return 0;
}

# set_ld_handler
# Set signal handler function.
sub set_ld_handler {
    $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;
    # HUP is actually used
    $SIG{ HUP  } = \&ld_handler_hup;
    # 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';
    # handle perl warn signal
    $SIG{__WARN__} = \&ld_handler_perl_warn;
}

# ld_handler_perl_warn
# Handle Perl warnings for logging file.
sub ld_handler_perl_warn {
    my $warning = join q{, }, @_;
    $warning =~ s/[\r\n]//g;
    ld_log( _message('WRN0301', $warning) );
}

# read_pid
# Read pid file and check if pid (l7directord) is still running
sub read_pid {
    my $old_pid  = undef;
    my $file_pid = undef;
    my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
    eval {
        open my $pid_handle, '<', $pid_file;
        $file_pid = <$pid_handle>;
        close $pid_handle;
        chomp $file_pid;

        # Check to make sure this isn't a stale pid file
        my $proc_file = "/proc/$file_pid/cmdline";
        open my $proc_handle, '<', $proc_file;
        my $line = <$proc_handle>;
        if ($line =~ /l7directord/) {
            $old_pid = $file_pid;
        }
        close $proc_handle;
    };
    
    return wantarray ? ($old_pid, $file_pid) : $old_pid;
}

# write_pid
# Write pid number to pid file.
sub write_pid {
    my $pid = shift;

    my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
    if (!defined $pid || $pid !~ /^\d+$/ || $pid < 1) {
        $pid = defined $pid ? $pid : 'undef';
        init_error( _message_only('ERR0412', $pid) );
    }
    eval {
        open my $pid_handle, '>', $pid_file;
        print {$pid_handle} $pid . "\n";
        close $pid_handle;
    };
    if ($EVAL_ERROR) {
        init_error( _message_only('ERR0409', $pid_file, $EVAL_ERROR) );
    }
}

# remove_pid
# Remove pid file.
sub remove_pid {
    my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
    ld_rm_file($pid_file);
}

# init_error
# Handle error during initialization and exit.
sub init_error {
    my $msg = shift;
    if (defined $msg) {
        if ($DEBUG_LEVEL == 0) {
            print {*STDERR} $msg . "\n";
        }
        ld_log( _message('ERR0001', $msg) );
    }
    ld_exit( 4, _message_only('INF0004') );
}

# ld_handler_term
# If we get a sinal then put a halt flag up
sub ld_handler_term {
    my $signal = shift;
    $PROC_STAT{halt} = defined $signal ? $signal : 'undef';
}

# ld_handler_hup
# If we get a sinal then put a reload flag up
sub ld_handler_hup {
    my $signal = shift;
    $PROC_STAT{reload} = defined $signal ? $signal : 'undef';
}

# reread_config
# Re-read config, and then re-setup l7vsd and child process.
sub reread_config {
    my $old_virtual = defined $CONFIG{virtual} ? [ @{ $CONFIG{virtual} } ]
                    :                            []
                    ;
    my %old_sub_config = defined $CONFIG{execute} ? %{ $CONFIG{execute} }
                       :                            ()
                       ;

    %CONFIG = %GLOBAL;
    $CONFIG{old_virtual} = $old_virtual;

    # analyze config and catch format error
    eval {
        read_config();
        ld_setup();
        ld_start();
    };
    if ($EVAL_ERROR) {
        my $exception = $EVAL_ERROR;
        chomp $exception;
        ld_log( _message('ERR0122', $exception) );
        $CONFIG{virtual} = [ @{ $CONFIG{old_virtual} } ];
        $CONFIG{execute} = \%old_sub_config;
    }

    my %new_sub_config = defined $CONFIG{execute} ? %{ $CONFIG{execute} }
                       :                            ()
                       ;
    for my $sub_config ( keys %old_sub_config ) {
        if ( exists $new_sub_config{$sub_config} ) {
            if ( system_wrapper($PROC_ENV{l7directord} . " $sub_config reload") ) {
                 system_wrapper($PROC_ENV{l7directord} . " $sub_config start");
            }
            delete $new_sub_config{$sub_config};
            delete $old_sub_config{$sub_config};
        }
    }
    ld_cmd_children('stop',  \%old_sub_config);
    ld_cmd_children('start', \%new_sub_config);
}

# read_config
# Read configuration and parse settings.
sub read_config {
    my $line = 0;
    my $current_global_name = q{};
    my $config_handle;

    eval {
        open $config_handle, '<', $CONFIG_FILE{path};
    };
    if ($EVAL_ERROR) {
        config_error( 0, 'ERR0407', $CONFIG_FILE{path} );
    }

    while (my $config_line = <$config_handle>) {
        $line++;
        chomp $config_line;
        $config_line =~ s/#.*//mg; # remove comment (FIXME optimize regex for "foo='#'")
        $config_line =~ s/^\t/$SECTION_VIRTUAL_PREFIX/mg; # convert tab to prefix

        next if ($config_line =~ /^(?:$SECTION_VIRTUAL_PREFIX)?\s*$/);

        # section global
        if ($config_line !~ /^$SECTION_VIRTUAL_PREFIX/) {
            my ($name, $value) = validate_config($line, $config_line);
            $current_global_name = $name;
            if ($name eq 'virtual') {
                my %virtual = %VIRTUAL;
                $virtual{server} = $value;
                push @{ $CONFIG{virtual} }, \%virtual;
                _ld_service_resolve(\%virtual, $value->{port});
            }
            elsif ($name eq 'execute') {
                $CONFIG{execute}{$value} = 1;
            }
            else {
                $CONFIG{$name} = $value;
            }
        }
        # section virtual
        else {
            if ($current_global_name ne 'virtual') {
                config_error($line, 'ERR0119', $config_line);
            }
            my ($name, $value) = validate_config($line, $config_line);
            if ($name eq 'real' && defined $value) {
                push @{ $CONFIG{virtual}[-1]{real} }, @$value;
            }
            elsif (defined $value) {
                $CONFIG{virtual}[-1]{$name} = $value;
            }
        }
    }

    eval {
        close $config_handle;
    };
    if ($EVAL_ERROR) {
        config_error( 0, 'ERR0408', $CONFIG_FILE{path} );
    }

    ld_openlog( $CONFIG{logfile} ) if !$PROC_STAT{log_opened};
    check_require_module();
    undef $CONFIG_FILE{checksum};
    undef $CONFIG_FILE{stattime};
    check_cfgfile();

    $PROC_STAT{initialized} = 1;
}

# validate_config
# Validation check of configuration.
sub validate_config {
    my ($line, $config) = @_;
    my ($name, $value) = split /\s*=\s*/, $config, 2;
    if (defined $value) {
        $value =~ s/\s*$//;
        $value =~ s/^("|')(.*)\1$/$2/;
    }

    # section global validate
    if ($name !~ /^$SECTION_VIRTUAL_PREFIX/) {
        if (!exists $GLOBAL{$name}) {
            config_error($line, 'ERR0120', $config);
        }
        if ($name eq 'virtual') {
            $value = ld_gethostservbyname($value, 'tcp');
            if (!defined $value) {
                config_error($line, 'ERR0114', $config);
            }
        }
        elsif (    $name eq 'checktimeout'
                || $name eq 'negotiatetimeout'
                || $name eq 'checkinterval'
                || $name eq 'retryinterval'
                || $name eq 'configinterval'
                || $name eq 'checkcount'      ) {
            if (!defined $value || $value !~ /^\d+$/ || $value == 0 ) {
                config_error($line, 'ERR0101', $config);
            }
        }
        elsif (    $name eq 'autoreload'
                || $name eq 'quiescent'  ) {
            $value = defined $value && $value =~ /^yes$/i ? 1
                   : defined $value && $value =~ /^no$/i  ? 0
                   :                                     undef
                   ;
            if (!defined $value) {
                config_error($line, 'ERR0102', $config);
            }
        }
        elsif ($name eq 'fallback') {
            my $fallback = parse_fallback($line, $value, $config);
            $value = {tcp => $fallback};
        }
        elsif ($name eq 'callback') {
            if (!defined $value || !-f $value || !-x $value) {
                config_error($line, 'ERR0117', $config);
            }
        }
        elsif ($name eq 'execute') {
            if (!defined $value || !-f $value) {
                config_error($line, 'ERR0116', $config);
            }
        }
        elsif ($name eq 'logfile') {
            if (!defined $value || ld_openlog($value) ) {
                config_error($line, 'ERR0118', $config);
            }
        }
        elsif ($name eq 'supervised') {
            $value = 1;
        }
    }
    # section virtual validate
    else {
        $name =~ s/^$SECTION_VIRTUAL_PREFIX\s*//g;
        if (!exists $VIRTUAL{$name}) {
            config_error($line, 'ERR0120', $config);
        }
        if ($name eq 'real') {
            $value = parse_real($line, $value, $config);
        }
        elsif (    $name eq 'request'
                || $name eq 'receive'
                || $name eq 'login'
                || $name eq 'passwd'
                || $name eq 'database'
                || $name eq 'customcheck'
                || $name eq 'virtualhost' ) {
            if (!defined $value || $value !~ /^.+$/) {
                config_error($line, 'ERR0103', $config);
            }
        }
        elsif ($name eq 'checktype') {
            my $valid_type = qr{custom|connect|negotiate|ping|off|on|\d+};
            $value = lc $value;
            if (!defined $value || $value !~ /^(?:$valid_type)$/) {
                config_error($line, 'ERR0104', $config);
            }
            if ($value =~ /^\d+$/ && $value == 0) {
                config_error($line, 'ERR0104', $config);
            }
        }
        elsif (    $name eq 'checktimeout'
                || $name eq 'negotiatetimeout'
                || $name eq 'checkinterval'
                || $name eq 'retryinterval'
                || $name eq 'checkcount'
                || $name eq 'maxconn'         ) {
            if (!defined $value || $value !~ /^\d+$/ || ($name ne 'maxconn' && $value == 0) ) {
                config_error($line, 'ERR0101', $config);
            }
        }
        elsif ($name eq 'checkport') {
            if (!defined $value || $value !~ /^\d+$/ || $value == 0 || $value > 65535) {
                config_error($line, 'ERR0108', $config);
            }
        }
        elsif ($name eq 'scheduler') {
            my $valid_scheduler = qr{lc|rr|wrr};
            $value = lc $value;
            if (!defined $value || $value !~ /^(?:$valid_scheduler)$/) {
                config_error($line, 'ERR0105', $config);
            }
        }
        elsif ($name eq 'protocol') {
            $value = lc $value;
            if (!defined $value || $value !~ /^tcp$/) {
                config_error($line, 'ERR0109', $config);
            }
        }
        elsif ($name eq 'service') {
            $value = lc $value;
            my $valid_service = qr{http|https|ldap|ftp|smtp|pop|imap|nntp|dns|mysql|pgsql|sip|none};
            if (!defined $value || $value !~ /^(?:$valid_service)$/) {
                config_error($line, 'ERR0106', $config);
            }
        }
        elsif ($name eq 'httpmethod') {
            my $valid_method = qr{GET|HEAD};
            $value = uc $value;
            if (!defined $value || $value !~ /^(?:$valid_method)$/) {
                config_error($line, 'ERR0110', $config);
            }
        }
        elsif ($name eq 'fallback') {
            my $fallback = parse_fallback($line, $value, $config);
            $value = {tcp => $fallback};
        }
        elsif ($name eq 'quiescent') {
            $value = defined $value && $value =~ /^yes$/i ? 1
                   : defined $value && $value =~ /^no$/i  ? 0
                   :                                     undef
                   ;
            if (!defined $value) {
                config_error($line, 'ERR0102', $config);
            }
        }
        elsif ($name eq 'module') {
            my %key_option = ( url         => ['--pattern-match', '--uri-pattern-match', '--host-pattern-match'],
                               pfilter     => ['--pattern-match'],
                               sessionless => [],
                               ip          => [],
                               sslid       => [],
                             );
            my $module = undef;
            my $option = undef;
            my $key    = q{};
            if (defined $value) {
                $value =~ s/["']//g;
                ($module, $option) = split /\s+/, $value, 2;
            }
            $module = lc $module;
            if ( !defined $module || !exists $key_option{$module} ) {
                config_error($line, 'ERR0111', $config);
            }
            for my $key_opt ( @{$key_option{$module}} ) {
                if (defined $option && $option =~ /$key_opt\s+(\S+)/) {
                    $key .= q{ } if $key;
                    $key .= $key_opt . q{ } . $1;
                }
            }
            if ( !$key && @{$key_option{$module}} ) {
                # when omit cookie module key option
		my $key_opt = join q{' or `}, @{$key_option{$module}};
		config_error($line, 'ERR0112', $module, $key_opt, $config);
            }
            $value = {name => $module, option => $option, key => $key};
        }
        elsif ($name eq 'sorryserver') {
            my $sorry_server = ld_gethostservbyname($value, 'tcp');
            if (!defined $sorry_server) {
                config_error($line, 'ERR0114', $config);
            }
            $value = $sorry_server;
        }
        elsif (    $name eq 'qosup'
                || $name eq 'qosdown' ) {
            $value = uc $value;
            if ( !defined $value || ($value ne '0' && $value !~ /^[1-9]\d{0,2}[KMG]$/) ) {
                config_error($line, 'ERR0113', $config);
            }
        }
        elsif (    $name eq 'realdowncallback'
                || $name eq 'realrecovercallback' ) {
            if (!defined $value || !-f $value || !-x $value) {
                config_error($line, 'ERR0117', $config);
            }
        }
    }

    return ($name, $value);
}

# check_require_module
# Check service setting and require module.
sub check_require_module {
    my %require_module = (
        http    => [ qw( LWP::UserAgent LWP::Debug ) ],
        https   => [ qw( LWP::UserAgent LWP::Debug Crypt::SSLeay ) ],
        ftp     => [ qw( Net::FTP ) ],
        smtp    => [ qw( Net::SMTP ) ],
        pop     => [ qw( Net::POP3 ) ],
        imap    => [ qw( Mail::IMAPClient ) ],
        ldap    => [ qw( Net::LDAP ) ],
        nntp    => [ qw( IO::Socket IO::Select ) ],
        dns     => [ qw( Net::DNS ) ],
        mysql   => [ qw( DBI DBD::mysql ) ],
        pgsql   => [ qw( DBI DBD::Pg ) ],
        sip     => [ qw( IO::Socket::INET ) ],
        ping    => [ qw( Net::Ping ) ],
        connect => [ qw( IO::Socket::INET ) ],
    );
            
    for my $v ( @{ $CONFIG{virtual} } ) {
        next if !defined $v;
        next if ( !defined $v->{service} || !defined $v->{checktype} );
        my $check_service = q{};
        if ( $v->{checktype} eq 'negotiate' && $require_module{ $v->{service} } ) {
            $check_service = $v->{service};
        }
        elsif ($v->{checktype} eq 'ping' || $v->{checktype} eq 'connect') {
            $check_service = $v->{checktype};
        }
        else {
            next;
        }
        for my $module ( @{ $require_module{$check_service} } ) {
            my $module_path = $module . '.pm';
            $module_path =~ s{::}{/}g;
            eval {
                require $module_path;
            };
            if ($EVAL_ERROR) {
                config_error(0, 'ERR0123', $module, $check_service);
            }
        }
    }
}

# _ld_service_resolve
# Set service name from port number
# pre: vsrv: Virtual Service to resolve port
#      port: port in the form
# post: 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
sub _ld_service_resolve {
    my ($vsrv, $port) = @_;

    my %servname;
    my @p = qw( 80   443   21  25   110 119  143  389  53  3306  5432  5060 );
    my @s = qw( http https ftp smtp pop nntp imap ldap dns mysql pgsql sip  );
    @servname{@p} = @s;

    if (defined $vsrv && !defined $vsrv->{service} && defined $port) {
        $vsrv->{service} = exists $servname{$port} ? $servname{$port}
                         :                           'none'
                         ;
    }
}

# parse_fallback
# Parse a fallback server
# pre: line: line number fallback server was read from
#      fallback: Should be of the form
#                ip_address|hostname[:port|:service_name] masq
#      config_line: line read from configuration file
# 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, $config_line) = @_;

    if (!defined $fallback || $fallback !~ /^(\S+)(?:\s+(\S+))?$/) {
        config_error($line, 'ERR0114', $config_line);
    }
    my ($ip_port, $forward) = ($1, $2);
    $ip_port = ld_gethostservbyname($ip_port, 'tcp');
    if ( !defined $ip_port ) {
        config_error($line, 'ERR0114', $config_line);
    }
    if (defined $forward && $forward !~ /^masq$/i) {
        config_error($line, 'ERR0107', $config_line);
    }

    my %fallback = %REAL;
    $fallback{server} = $ip_port;
    if (defined $forward) {
        $fallback{forward} = $forward;
    }

    return \%fallback;
}

# parse_real
# Parse a real server
# pre: line: line number real server was read from
#      real: Should be of the form
#                ip_address|hostname[:port|:service_name] masq
#      config_line: line read from configuration file
# post: real is parsed
# return: Reference to array include real server hash reference
#         [ {server...}, {server...} ... ]
#         Debugging message will be reported and programme will exit
#         on error.
sub parse_real {
    my ($line, $real, $config_line) = @_;
    
    my $ip_host = qr{\d+\.\d+\.\d+\.\d+|[a-z0-9.-]+};
    my $port_service = qr{\d+|[a-z0-9-]+};
    if (    !defined $real
         || $real !~ /^
                      ($ip_host)             # ip or host
                      (?:->($ip_host))?      # range (optional)
                      (?::($port_service))?  # port or service (optional)
                      (?:\s+([a-z]+))?       # forwarding mode (optional)
                      (?:\s+(\d+))?          # weight (optional)
                      (?:\s+
                         ([^,\s]+)           # "request
                         \s*[ ,]\s*          #  separater
                         (\S+)               #  receive"
                      )?                     # (optional)
                      $/ix) {
        config_error($line, 'ERR0114', $config_line);
    }
    my ($ip1, $ip2, $port, $forward, $weight, $request, $receive)
     = (  $1,   $2,    $3,       $4,      $5,       $6,       $7);

    # set forward, weight and request-receive pair.
    my %real = %REAL;
    if (defined $forward) {
        $forward = lc $forward;
        if ($forward !~ /^masq$/) {
            config_error($line, 'ERR0107', $config_line);
        }
        $real{forward} = $forward;
    }
    if (defined $weight) {
        $real{weight} = $weight;
    }
    if (defined $request && defined $receive) {
        $request =~ s/^\s*("|')(.*)\1\s*/$2/;
        $receive =~ s/^\s*("|')(.*)\1\s*/$2/;
        $real{request} = $request;
        $real{receive} = $receive;
    }

    my $resolved_port = undef;
    if (defined $port) {
        $resolved_port = ld_getservbyname($port);
        if (!defined $resolved_port) {
            config_error($line, 'ERR0108', $config_line);
        }
    }

    my $resolved_ip1 = ld_gethostbyname($ip1);
    if (!defined $resolved_ip1) {
        config_error($line, 'ERR0114', $config_line);
    }

    my $resolved_ip2 = $resolved_ip1;
    if (defined $ip2) {
        $resolved_ip2 = ld_gethostbyname($ip2);
        if (!defined $resolved_ip2) {
            config_error($line, 'ERR0114', $config_line);
        }
    }

    my $int_ip1 = ip_to_int($resolved_ip1);
    my $int_ip2 = ip_to_int($resolved_ip2);
    if ($int_ip1 > $int_ip2) {
        config_error($line, 'ERR0115', $resolved_ip1, $resolved_ip2, $config_line);
    }

    my @reals = ();
    for (my $int_ip = $int_ip1; $int_ip <= $int_ip2; $int_ip++) {
        my %new_real = %real;
        $new_real{server}{ip  } = int_to_ip($int_ip);
        $new_real{server}{port} = $resolved_port;
        push @reals, \%new_real;
    }
    return \@reals;
}

# config_error
# Handle error during read configuration and validation check
sub config_error {
    my ($line, $msg_code, @msg_args) = @_;

    if ($DEBUG_LEVEL > 0 || $PROC_STAT{initialized} == 0) {
        my $msg = _message_only($msg_code, @msg_args);
        if (defined $line && $line > 0) {
            print {*STDERR} _message_only('ERR0121', $CONFIG_FILE{path}, $line, $msg) . "\n";
        }
        else {
            print {*STDERR} $msg . "\n";
        }
    }
    else {
        if ($line > 0) {
            ld_log( _message('ERR0121', $CONFIG_FILE{path}, $line, q{}) );
        }
        ld_log( _message($msg_code, @msg_args) );
    }
    if ( $PROC_STAT{initialized} == 0 ) {
        ld_exit(5, _message_only('ERR0002') );
    }
    else {
        die "Configuration error.\n";
    }
}

# ld_setup
# Check configuration value and set default value, overwrite global config value and so on.
sub ld_setup {
    if ( defined $CONFIG{virtual} ) {
        for my $v ( @{ $CONFIG{virtual} } ) {
            next if !defined $v;
            if (defined $v->{protocol} && $v->{protocol} eq 'tcp') {
                $v->{option}{protocol} = "-t";
            }
    
            if ( defined $v->{option} && defined $v->{option}{protocol} && defined $v->{module} && defined $v->{module}{name} ) {
                my $module_option = $v->{module}{name};
                if ( defined $v->{module}{option} ) {
                    $module_option .= q{ } . $v->{module}{option};
                }
                $v->{option}{main} = sprintf "%s %s -m %s", $v->{option}{protocol}, get_ip_port($v), $module_option;
                $v->{option}{flags} = $v->{option}{main};
                if ( defined $v->{scheduler} ) {
                    $v->{option}{flags} .= ' -s ' . $v->{scheduler};
                }
                if ( defined $v->{maxconn} ) {
                    $v->{option}{flags} .= ' -u ' . $v->{maxconn};
                }
                if ( defined $v->{sorryserver} && defined $v->{sorryserver}{ip} && defined $v->{sorryserver}{port} ) {
                    $v->{option}{flags} .= ' -b ' . $v->{sorryserver}{ip} . ':' . $v->{sorryserver}{port};
                }
                if ( defined $v->{qosup} ) {
                    $v->{option}{flags} .= ' -Q ' . $v->{qosup};
                }
                if ( defined $v->{qosdown} ) {
                    $v->{option}{flags} .= ' -q ' . $v->{qosdown};
                }
            }
    
            if ( !defined $v->{fallback} && defined $CONFIG{fallback} ) {
                $v->{fallback} = { %{ $CONFIG{fallback} } };
            }
            if ( defined $v->{fallback} ) {
                for my $proto ( keys %{ $v->{fallback} } ) {
                    $v->{fallback}{$proto}{option}{flags} = '-r ' . get_ip_port( $v->{fallback}{$proto} );
                }
            }
            if (defined $v->{checktype} && $v->{checktype} =~ /^\d+$/) {
                $v->{num_connects} = $v->{checktype};
                $v->{checktype} = 'combined';
            }
    
            if ( defined $v->{login} && $v->{login} eq q{} ) {
                $v->{login} = defined $v->{service} && $v->{service} eq 'ftp' ? 'anonymous'
                            : defined $v->{service} && $v->{service} eq 'sip' ? 'l7directord@' . $PROC_ENV{hostname}
                            :                                                   q{}
                            ;
            }
            if ( defined $v->{passwd} && $v->{passwd} eq q{} ) {
                $v->{passwd} = defined $v->{service} && $v->{service} eq 'ftp' ? 'l7directord@' . $PROC_ENV{hostname}
                             :                                                   q{}
                             ;
            }
    
            if ( defined $v->{real} ) {
                for my $r ( @{ $v->{real} } ) {
                    next if !defined $r;
                    if ( defined $r->{forward} ) {
                        $r->{option}{forward} = get_forward_flag( $r->{forward} );
                    }
                    if ( !defined $r->{weight} || $r->{weight} !~ /^\d+$/ ) {
                        $r->{weight} = 1;
                    }
        
                    if ( !defined $r->{server}{port} ) {
                        $r->{server}{port} = $v->{server}{port};
                    }

                    $r->{option}{flags} = '-r ' . get_ip_port($r);
        
                    # build request URL
                    if ( defined $v->{service} && defined $r->{server} ) {
                        my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
                        $r->{url} = sprintf "%s://%s:%s/",
                                            $v->{service}, $r->{server}{ip}, $port;
                    }
                    if ( !defined $r->{request} && defined $v->{request} ) {
                        $r->{request} = $v->{request};
                    }
                    if ( !defined $r->{receive} && defined $v->{receive} ) {
                        $r->{receive} = $v->{receive};
                    }
                    if ( defined $r->{request} ) {
                        my $uri = $r->{request};
                        my $service = $v->{service};
                        if ( defined $v->{service} && $uri =~ m{^$service://} ) {
                            $r->{url} = $uri;
                        }
                        else {
                            $uri =~ s{^/+}{}g;
                            $r->{url} .= $uri;
                        }
                    }
                    
                    # set connect count for combine check
                    if (defined $v->{checktype} && $v->{checktype} eq 'combined') {
                        $r->{num_connects} = undef;
                    }
        
                    $r->{fail_counts} = 0;
                    $r->{healthchecked} = 0;
                }
            }
            if ( !defined $v->{checkcount} || $v->{checkcount} <= 0 ) {
                $v->{checkcount} = $CONFIG{checkcount};
            }
            if ( !defined $v->{checktimeout} || $v->{checktimeout} <= 0 ) {
                $v->{checktimeout} = $CONFIG{checktimeout};
            }
            if ( !defined $v->{negotiatetimeout} || $v->{negotiatetimeout} <= 0 ) {
                $v->{negotiatetimeout} = $CONFIG{negotiatetimeout};
            }
            if ( !defined $v->{checkinterval} || $v->{checkinterval} <= 0 ) {
                $v->{checkinterval} = $CONFIG{checkinterval};
            }
            if ( !defined $v->{retryinterval} || $v->{retryinterval} <= 0 ) {
                $v->{retryinterval} = $CONFIG{retryinterval};
            }
            if ( !defined $v->{quiescent} ) {
                $v->{quiescent} = $CONFIG{quiescent};
            }
        }
    }

    if (defined $CONFIG{fallback}) {
        $CONFIG{fallback}{tcp}{option}{flags} = '-r ' . get_ip_port( $CONFIG{fallback}{tcp} );
    }
}

# 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.
sub ld_read_l7vsadm {
    my $current_service = {};
    my $vip_id;

    if ( !-f $PROC_ENV{l7vsadm} || !-x $PROC_ENV{l7vsadm} ) {
        ld_log( _message( 'FTL0101', $PROC_ENV{l7vsadm} ) );
        return $current_service;
    }
    # read status of current l7vsadm -K -n
    # -K indicates Key parameters of the module included.
    my $list_command = $PROC_ENV{l7vsadm} . " -K -n";
    my $cmd_result = qx{$list_command};
    my @list_line = split /\n/, $cmd_result;

    # skip below header
    # [cf] Layer-7 Virtual Server version 2.0.0-0
    # [cf] Prot LocalAddress:Port ProtoMod Scheduler Reschedule Protomod_key_string
    # [cf]   -> RemoteAddress:Port           Forward Weight ActiveConn InactConn
    shift @list_line; shift @list_line; shift @list_line;

    for my $line (@list_line) {
        # check virtual service line format
        # [cf] TCP 192.168.0.4:12121 cinsert rr 0 --cookie-name CookieName
        if ($line =~ /
                ^           # top
                (\w+) \s+   # 'TCP'
                (\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}:\d{1,5}) \s+ # ip port
                (\w+) \s+   # protocol module
                \w+ \s+     # scheduler
                (?:0|1) \s+ # reschedule flag
                (.*)        # module key
                $           # end
                /x
            ) {
            my ($proto, $ip_port, $module, $key) = ($1, $2, $3, $4);
            # vip_id MUST be same format as get_virtual_id_str
            $proto = lc $proto;
            $vip_id = "$proto:$ip_port:$module $key";
            $vip_id =~ s/\s+$//;
            $current_service->{$vip_id} = undef;
            next;
        }
        # check real server line format
        # [cf] -> 192.168.0.4:7780             Masq    1     10     123456      
        if (defined $vip_id && $line =~ /
                ^           # top
                \s+ -> \s+  # arrow
                (\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}):(\d{1,5}) \s+ # ip port
                (\w+) \s+   # 'Masq'
                (\d+) \s+   # weight
                \d+ \s+     # active connections
                \d+ \s*     # inactive connections
                $           # end
                /x
            ) {
            my ($ip, $port, $forward, $weight) = ($1, $2, $3, $4);
            my $ip_port = "$ip:$port";
            my $real = {
                    server  => { ip => $ip, port => $port },
                    weight  => $weight,
                    forward => $forward,
                    option  => {
                                flags   => "-r $ip_port",
                                forward => get_forward_flag($forward),
                                },
            };
            $current_service->{$vip_id}{$ip_port} = $real;
        }
    }

    return $current_service;
}

# ld_operate_virtual
# Operate virtual service on l7vsd by l7vsadm command.
sub ld_operate_virtual {
    my ($v, $option, $success_code, $error_code) = @_;
    if (!defined $v || !defined $option || !defined $success_code || !defined $error_code) {
        ld_log( _message('ERR0501') );
        return;
    }

    my $command = $PROC_ENV{l7vsadm} . " $option ";
    if ($option ne '-D') {
        $command .= $v->{option}{flags};
    }
    else {
        $command .= $v->{option}{main};
    }
    $command .= ' 2>&1';

    my ($result, $output) = command_wrapper($command);

    my $module_key = $v->{module}{name};
    if ( defined $v->{module}{key} ) {
        $module_key .= q{ } . $v->{module}{key};
    }
    if ($result == 0) {
        ld_log( _message($success_code, get_ip_port($v), $module_key) );
    }
    else {
        ($output) = split /\n/, $output, 2;
        ld_log( _message($error_code, get_ip_port($v), $module_key, $output) );
    }
}

# ld_add_virtual
# Call operate virtual with add option.
sub ld_add_virtual {
    my $v = shift;
    ld_operate_virtual($v, '-A', 'INF0201', 'ERR0201');
}

# ld_edit_virtual
# Call operate virtual with edit option.
sub ld_edit_virtual {
    my $v = shift;
    ld_operate_virtual($v, '-E', 'INF0202', 'ERR0202');
}

# ld_delete_virtual
# Call operate virtual with delete option.
sub ld_delete_virtual {
    my $v = shift;
    ld_operate_virtual($v, '-D', 'INF0203', 'ERR0203');
}

# ld_operate_real
# Operate real server on l7vsd by l7vsadm command.
sub ld_operate_real {
    my ($v, $r, $weight, $option, $success_code, $error_code) = @_;
    if (!defined $v || !defined $r || !defined $option || !defined $success_code || !defined $error_code) {
        ld_log( _message('ERR0501') );
        return;
    }

    my $command
        = $PROC_ENV{l7vsadm} . " $option " . $v->{option}{main} . q{ } . $r->{option}{flags};

    # replace weight value
    if (defined $weight) {
        $command .= ' -w ' . $weight;
    }
    $command .= ' 2>&1';

    my ($result, $output) = command_wrapper($command);

    my $module_key = $v->{module}{name};
    if ( defined $v->{module}{key} ) {
        $module_key .= q{ } . $v->{module}{key};
    }
    if ($result == 0) {
        ld_log( _message($success_code, get_ip_port($r), get_ip_port($v), $module_key, $weight) );
    }
    else {
        ($output) = split /\n/, $output, 2;
        ld_log( _message($error_code, get_ip_port($r), get_ip_port($v), $module_key, $output) );
    }
}

# ld_add_real
# Call operate real with add option.
sub ld_add_real {
    my ($v, $r, $weight) = @_;
    ld_operate_real($v, $r, $weight, '-a', 'INF0204', 'ERR0204');
}

# ld_edit_real
# Call operate real with edit option.
sub ld_edit_real {
    my ($v, $r, $weight) = @_;
    ld_operate_real($v, $r, $weight, '-e', 'INF0205', 'ERR0205');
}

# ld_delete_real
# Call operate real with delete option.
sub ld_delete_real {
    my ($v, $r) = @_;
    ld_operate_real($v, $r, undef, '-d', 'INF0206', 'ERR0206');
}

# ld_start
# Check l7vsd by l7vsadm command and create virtual service on l7vsd.
sub ld_start {
    # read status of current l7vsadm -K -n
    my $current_service = ld_read_l7vsadm();
    if (!defined $current_service) {
        ld_log( _message('FTL0201') );
        return;
    }

    my %old_health_check = %HEALTH_CHECK;
    %HEALTH_CHECK = ();

    # make sure virtual servers are up to date
    if ( defined $CONFIG{virtual} ) {
        for my $nv ( @{ $CONFIG{virtual} } ) {
            my $vip_id = get_virtual_id_str($nv);
            if (!defined $vip_id) {
                ld_log( _message('ERR0502') );
                return;
            }
    
            if ( exists( $current_service->{$vip_id} ) ) {
                # service already exists, modify it
                ld_edit_virtual($nv);
            }
            else {
                # no such service, create a new one
                ld_add_virtual($nv);
            }
    
            my $or = $current_service->{$vip_id} || {};
    
            # Not delete fallback server from l7vsd if exist
            my $fallback = fallback_find($nv);
            if (defined $fallback) {
                my $fallback_ip_port = get_ip_port( $fallback->{ $nv->{protocol} } );
                delete $or->{$fallback_ip_port};
                fallback_on($nv);
            }
    
            if ( defined $nv->{real} ) {
                CHECK_REAL:
                for my $nr ( @{ $nv->{real} } ) {
                    delete $or->{ get_ip_port($nr) };
        
                    my $health_check_id = get_health_check_id_str($nv, $nr);
                    if (!defined $health_check_id) {
                        ld_log( _message('ERR0503') );
                        return;
                    }
        
                    # search same health check process
                    if ( exists $HEALTH_CHECK{$health_check_id} ) {
                        # same health check process exist
                        # then check real server and virtual service ($r, $v)
                        for my $v_r_pair ( @{ $HEALTH_CHECK{$health_check_id}{manage} } ) {
                            # completely same. check next real server
                            next CHECK_REAL if ($nv eq $v_r_pair->[0] && $nr eq $v_r_pair->[1]);
                        }
        
                        # add real server and virtual service to management list
                        push @{ $HEALTH_CHECK{$health_check_id}{manage} }, [$nv, $nr];
                    }
                    else {
                        # add to health check process list
                        $HEALTH_CHECK{$health_check_id}{manage} = [ [$nv, $nr] ];
                    }
                }
            }
    
            # remove remaining entries for real servers
            for my $remove_real_ip_port (keys %$or) {
                ld_delete_real( $nv, $or->{$remove_real_ip_port} );
                delete $or->{$remove_real_ip_port};
            }
    
            delete $current_service->{$vip_id};
        }
    }

    # terminate old health check process
    # TODO should compare old and new, and only if different then re-create process...
    for my $id (keys %old_health_check) { 
        # kill old health check process
        if ( defined $old_health_check{$id}{pid} ) {
            # TODO cannot kill process during pinging to unreachable host?
            {
                local $SIG{ALRM} = sub { die; };
                kill 15, $old_health_check{$id}{pid};
                eval {
                    alarm 3;
                    waitpid $old_health_check{$id}{pid}, 0;
                    alarm 0;
                };
                alarm 0;
                if ($EVAL_ERROR) {
                    kill 9, $old_health_check{$id}{pid};
                    waitpid $old_health_check{$id}{pid}, WNOHANG;
                }
            }
        }
    }

    # remove remaining entries for virtual servers
    if ( defined $CONFIG{old_virtual} ) {
        for my $nv ( @{ $CONFIG{old_virtual} } ) {
            my $vip_id = get_virtual_id_str($nv);
            if ( exists $current_service->{$vip_id} ) {
                # service still exists, remove it
                ld_delete_virtual($nv);
            }
        }
    }
    delete $CONFIG{old_virtual};
}

# ld_cmd_children
# Run l7directord command to child process.
# Child process is not health check process,
# but sub config (specified by configuration with `execute') process.
sub ld_cmd_children {
    my $command_type = shift;
    my $execute = shift;

    # instantiate other l7directord, if specified
    if (!defined $execute) {
        if ( defined $CONFIG{execute} ) {
            for my $sub_config ( keys %{ $CONFIG{execute} } ) {
                if (defined $command_type && defined $sub_config) {
                    my $command = $PROC_ENV{l7directord} . " $sub_config $command_type";
                    system_wrapper($command);
                }
            }
        }
    }
    else {
        for my $sub_config ( keys %$execute ) {
            if (defined $command_type && defined $sub_config) {
                my $command = $PROC_ENV{l7directord} . " $sub_config $command_type";
                system_wrapper($command);
            }
        }
    }
}

# ld_stop
# Remove virtual service for stopping this program.
sub ld_stop {
    my $srv = ld_read_l7vsadm();
    if (!defined $srv) {
        ld_log( _message('FTL0201') );
        return;
    }
    if ( defined $CONFIG{virtual} ) {
        for my $v ( @{ $CONFIG{virtual} } ) {
            my $vid = get_virtual_id_str($v);
            if (!defined $vid) {
                ld_log( _message('ERR0502') );
                return;
            }
            if ( exists $srv->{$vid} ) {
                for my $rid ( keys %{ $srv->{$vid} } ) {
                    ld_delete_real( $v, $srv->{$vid}{$rid} );
                }
            }
            ld_delete_virtual($v);
        }
    }
}

# ld_main
# Main function of this program.
# Create virtual service and loop below 3 steps.
# 1. Check health check sub process and (re-)create sub process as needed
# 2. Check signal in sleep and start to terminate program or reload config as needed
# 3. Check config file and reload config as needed
sub ld_main {
    ld_start();

    # Main failover checking code
    MAIN_LOOP:
    while (1) {
        # manage real server check process.
        REAL_CHECK:
        while (1) {
            my @id_lists = check_child_process();
            # if child process is not running
            if (@id_lists) {
                create_check_process(@id_lists);
            }
            my $signal = sleep_and_check_signal( $CONFIG{configinterval} );
            last MAIN_LOOP  if defined $signal && $signal eq 'halt';
            last REAL_CHECK if defined $signal && $signal eq 'reload';
            last REAL_CHECK if check_cfgfile();
        }

        # reload config
        reread_config();
    }

    # signal TERM to child process
    for my $id (keys %HEALTH_CHECK) {
        if ( defined $HEALTH_CHECK{$id}{pid} ) {
            # TODO cannot kill process during pinging to unreachable host?
            {
                local $SIG{ALRM} = sub { die; };
                kill 15, $HEALTH_CHECK{$id}{pid};
                eval {
                    alarm 3;
                    waitpid $HEALTH_CHECK{$id}{pid}, 0;
                    alarm 0;
                };
                alarm 0;
                if ($EVAL_ERROR) {
                    kill 9, $HEALTH_CHECK{$id}{pid};
                    waitpid $HEALTH_CHECK{$id}{pid}, WNOHANG;
                }
            }
        }
    }
    ld_stop();
}

# check_child_process
# Check health check process by signal zero.
# return: Health check id list that (re-)created later.
sub check_child_process {
    my @down_process_ids = ();
    for my $id (sort keys %HEALTH_CHECK) {
        if ( !defined $HEALTH_CHECK{$id}{pid} ) {
            # not create ever
            ld_log( _message('INF0401', $id) );
            push @down_process_ids, $id;
            next;
        }
        # non-blocking wait for zombie process
        waitpid(-1, WNOHANG); # TODO should move to sigchld handler?
        # signal 0
        my $signaled = kill 0, $HEALTH_CHECK{$id}{pid};
        if ($signaled != 1) {
            # maybe killed from outside
            ld_log( _message('ERR0603', $HEALTH_CHECK{$id}{pid}, $id) );
            push @down_process_ids, $id;
            next;
        }
    }
    return @down_process_ids;
}

# create_check_process
# Fork health check sub process.
# And health check sub process run health_check sub function.
sub create_check_process {
    my @id_lists = @_;
    for my $health_check_id (@id_lists) {
        my $pid = fork();
        if ($pid > 0) {
            ld_log( _message('INF0402', $pid, $health_check_id) );
            $HEALTH_CHECK{$health_check_id}{pid} = $pid;
        }
        elsif ($pid == 0) {
            $PROC_STAT{parent_pid} = $PROC_STAT{pid};
            $PROC_STAT{pid} = $PID;
            health_check( $HEALTH_CHECK{$health_check_id}{manage} );
        }
        else {
            ld_log( _message('ERR0604', $health_check_id) );
        }
        sleep 1;
    }
}

# health_check
# Main function of health check process.
# Loop below.
# 1. Health check.
# 2. Status change and reflect to l7vsd as needed.
# 3. Check signal in sleep.
# pre: v_r_list: reference list of virtual service and real server pair
#     $v_r_list = [ [$virtual, $real], [$virtual, $real], ... ];
# return: none
#         MUST use POSIX::_exit when terminate sub process.
sub health_check {
    my $v_r_list = shift;
    if (!defined $v_r_list) {
        ld_log( _message('ERR0501') );
        ld_log( _message('FTL0001') );
        POSIX::_exit(1);
    }

    # you can use any virtual, real pair in $v_r_list.
    my ($v, $r) = @{ $v_r_list->[0] };
    if (!defined $v || !defined $r) {
        ld_log( _message('FTL0002') );
        POSIX::_exit(2);
    }

    my $health_check_func = get_check_func($v);
    my $current_status = get_status($v_r_list);

    my $status = 'STARTING';
    my $type = $v->{checktype} eq 'negotiate' ? $v->{service}
             : $v->{checktype} eq 'combined'  ? $v->{service} . '(combined)'
             :                                  $v->{checktype}
             ;
    $PROGRAM_NAME = 'l7directord: ' . $type . ':' . get_ip_port($r) . ':' . $status;
    
    while (1) {
        # health check
        my $service_status = &$health_check_func($v, $r);
        
        if ($service_status == $SERVICE_DOWN) {
            if (!defined $current_status || $current_status == $SERVICE_UP) {
                $r->{fail_counts}++;
                undef $r->{num_connects};
                if ($r->{fail_counts} >= $v->{checkcount}) {
                    ld_log( _message( 'ERR0602', get_ip_port($r) ) );
                    service_set($v_r_list, 'down');
                    $current_status = $SERVICE_DOWN;
                    $status = 'DOWN';
                    $r->{fail_counts} = 0;
                }
                else {
                    ld_log( _message( 'WRN1001', get_ip_port($r), $v->{checkcount} - $r->{fail_counts} ) );
                    $status = sprintf "NG[%d/%d]", $r->{fail_counts}, $v->{checkcount};
                }
            }
        }
        if ($service_status == $SERVICE_UP) {
            $r->{fail_counts} = 0;
            if (!defined $current_status || $current_status == $SERVICE_DOWN) {
                ld_log( _message( 'ERR0601', get_ip_port($r) ) );
                service_set($v_r_list, 'up');
                $current_status = $SERVICE_UP;
            }
            $status = 'UP';
        }

        $PROGRAM_NAME = 'l7directord: ' . $type . ':' . get_ip_port($r) . ':' . $status;

        my $sleeptime = $r->{fail_counts} ? $v->{retryinterval} : $v->{checkinterval};
        last if (sleep_and_check_signal($sleeptime, 1) eq 'halt');

        my $parent_process = kill 0, $PROC_STAT{parent_pid};
        if ($parent_process != 1) {
            ld_log( _message( 'FTL0003', $PROC_STAT{parent_pid} ) );
            POSIX::_exit(3);
        }
    }

    ld_log( _message('INF0007') );
    POSIX::_exit(0);
}

# sleep_and_check_signal
# Check signal flag each 0.1 secound with sleeping specified seconds.
sub sleep_and_check_signal {
    my ($sec, $is_child) = @_;
    if (!defined $sec || $sec !~ /^\d+$/) {
        ld_log( _message('ERR0501') );
        return 'halt';
    }

    my $sleeped = 0;
    while ($sec > $sleeped) {
        if ($is_child) {
            if ( defined $PROC_STAT{halt} ) { 
                ld_log( _message( 'WRN0001', $CONFIG_FILE{path}, $PROC_STAT{halt} ) );
                return 'halt';
            }
        }
        else {
            if ( defined $PROC_STAT{halt} ) { 
                ld_log( _message( 'WRN0001', $CONFIG_FILE{path}, $PROC_STAT{halt} ) );
                return 'halt';
            }
            if ( defined $PROC_STAT{reload} ) {
                ld_log( _message( 'WRN0002', $CONFIG_FILE{path}, $PROC_STAT{reload} ) );
                undef $PROC_STAT{reload};
                return 'reload';
            }
        }
        sleep 0.1;
        $sleeped += 0.1;
    }
    return 'run';
}

# get_check_func
# Determine check function by checktype and service.
sub get_check_func {
    my $v = shift;
    if (!defined $v) {
        ld_log( _message('ERR0501') );
        return \&check_off;
    }

    my $type = $v->{checktype};
    my $service_func = {
        http  => \&check_http,
        https => \&check_http,
        pop   => \&check_pop,
        imap  => \&check_imap,
        smtp  => \&check_smtp,
        ftp   => \&check_ftp,
        ldap  => \&check_ldap,
        nntp  => \&check_nntp,
        dns   => \&check_dns,
        sip   => \&check_sip,
        mysql => \&check_mysql,
        pgsql => \&check_pgsql,
    };

    if ( defined $type && ($type eq 'negotiate' || $type eq 'combined') ) {
        if (defined $v->{service} && exists $service_func->{ $v->{service} } ) {
            my $negotiate_func = $service_func->{ $v->{service} };
            if ($type eq 'negotiate') {
                return $negotiate_func;
            }
            elsif ($type eq 'combined') {
                my $combined_func =  make_combined_func($negotiate_func);
                return $combined_func;
            }
        }
        else {
            return \&check_none;
        }
    }

    if (defined $type && $type eq 'custom') {
        my $custom_func = make_custom_func( $v->{customcheck} );
        return $custom_func;
    }

    if (defined $type && $type eq 'connect') {
        if (defined $v->{protocol} && $v->{protocol} eq 'tcp') {
            return \&check_connect;
        }
        else {
            return \&check_ping;
        }
    }

    if (defined $type && $type eq 'ping') {
        return \&check_ping;
    }

    if (defined $type && $type eq 'off') {
        return \&check_off;
    }

    if (defined $type && $type eq 'on') {
        return \&check_on;
    }

    return \&check_none;
}

# make_combined_func
# Create combined function.
sub make_combined_func {
    my $negotiate_func = shift;
    if (!defined $negotiate_func) {
        ld_log( _message('ERR0504') );
        return \&check_connect;
    }

    # closure
    my $combined_func = sub {
        my ($v, $r) = @_;
        my $timing    = $v->{num_connects};
        my $connected = $r->{num_connects};

        if (!defined $connected ||
            (defined $timing && $timing <= $connected) ) {
            $r->{num_connects} = 0;
            return &$negotiate_func($v, $r);
        }
        else {
            $r->{num_connects}++;
            return check_connect($v, $r);
        }
    };

    return $combined_func;
}

# make_custom_func
# Create custom check function.
sub make_custom_func {
    my $customcheck = shift;
    if (!defined $customcheck) {
        ld_log( _message('ERR0505') );
        return \&check_off;
    }

    # closure
    my $custom_func = sub {
        my ($v, $r) = @_;
        my $status = get_status([[$v, $r]]);
        my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
        my $ip_port  = $r->{server}{ip} . ':' . $port;

        # expand macro
        $customcheck =~ s/_IP_/$r->{server}{ip}/g;
        $customcheck =~ s/_PORT_/$port/g;

        my $res;
        {
            local $SIG{__DIE__} = 'DEFAULT';
            local $SIG{ALRM} = sub { die "custom check timeout\n"; };
            eval {
                alarm $v->{negotiatetimeout};
                $res = system_wrapper($customcheck);
                alarm 0;
            };
            alarm 0;
            if ($EVAL_ERROR) {
                ld_log( _message('WRN3301', $v->{checktimeout}, $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
                return $SERVICE_DOWN;
            }
        }
        if ($res) {
                ld_log( _message('WRN3302', $customcheck, $res) ) if (!defined $status || $status eq $SERVICE_UP);
                return $SERVICE_DOWN;
        }
        ld_log( _message('WRN0215', $ip_port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
        return $SERVICE_UP;
    };

    return $custom_func;
}

# check_http
# HTTP service health check.
# Send GET/HEAD request, and check response
sub check_http {
    require LWP::UserAgent;
    require LWP::Debug;
    if ( $DEBUG_LEVEL > 2 ) {
        LWP::Debug::level('+');
    }
    my ( $v, $r ) = @_;
    my $status = get_status([[$v, $r]]);

    my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};

    if ( $r->{url} !~ m{^https?://([^:/]+)} ) {
        ld_log( _message( 'WRN1101', $r->{url}, $r->{server}{ip}, $port ) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }
    my $host = $1;
    my $virtualhost = defined $v->{virtualhost} ? $v->{virtualhost} : $host;

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

    my $ua = LWP::UserAgent->new( timeout => $v->{negotiatetimeout} );
    my $req = new HTTP::Request( $v->{httpmethod}, $r->{url}, [ Host => $virtualhost ] );
    my $res;
    {
        # LWP makes ungaurded calls to eval
        # which throw a fatal exception if they fail
        local $SIG{__DIE__} = 'DEFAULT';
        local $SIG{ALRM} = sub { die "Can't connect to $r->{server}{ip}:$port (connect: timeout)\n"; };
        eval {
            alarm $v->{negotiatetimeout};
            $res = $ua->request($req);
            alarm 0;
        };
        alarm 0;
    }

    my $status_line = $res->status_line;
    $status_line =~ s/[\r\n]//g;

    my $recstr = $r->{receive};
    if (!$res->is_success) {
        ld_log( _message( 'WRN1102', $status_line, $r->{server}{ip}, $port ) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }
    elsif (defined $recstr && $res->as_string !~ /$recstr/) {
        ld_log( _message( 'WRN1103', $recstr, $r->{server}{ip}, $port ) ) if (!defined $status || $status eq $SERVICE_UP);
        ld_debug(3, "Headers " . $res->headers->as_string);
        ld_debug(2, "check_http: $r->{url} is down\n");
        return $SERVICE_DOWN;
    }

    ld_debug(2, "check_http: $r->{url} is up\n");
    ld_log( _message( 'WRN0203', $status_line, $r->{server}{ip}, $port ) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
    return $SERVICE_UP;
}

# check_smtp
# SMTP service health check.
# Connect SMTP server and check first response
sub check_smtp {
    require Net::SMTP;
    my ($v, $r) = @_;
    my $status = get_status([[$v, $r]]);

    my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};

    ld_debug(2, "Checking http: server=$r->{server}{ip} port=$port");
    my $debug_flag = $DEBUG_LEVEL ? 1 : 0;

    my $smtp = Net::SMTP->new(
        $r->{server}{ip},
        Port    => $port,
        Timeout => $v->{negotiatetimeout},
        Debug   => $debug_flag,
    );
    if (!$smtp) {
        ld_log( _message('WRN1201', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }
    $smtp->quit;

    ld_log( _message('WRN0204', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
    return $SERVICE_UP;
}

# check_pop
# POP3 service health check.
# Connect POP3 server and login if user-pass specified.
sub check_pop {
    require Net::POP3;
    my ($v, $r) = @_;
    my $status = get_status([[$v, $r]]);

    my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};

    ld_debug(2, "Checking pop server=$r->{server}{ip} port=$port");
    my $debug_flag = $DEBUG_LEVEL ? 1 : 0;

    my $pop = Net::POP3->new(
        $r->{server}{ip},
        Port    => $port,
        Timeout => $v->{negotiatetimeout},
        Debug   => $debug_flag,
    );
    if (!$pop) {
        ld_log( _message('WRN1301', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }

    if ( defined $v->{login} && defined $v->{passwd} && $v->{login} ne q{} ) {
        $pop->user( $v->{login} );
        my $num = $pop->pass( $v->{passwd} );
        if (!defined $num) {
            ld_log( _message('WRN1302', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
            $pop->quit();
            return $SERVICE_DOWN;
        }
    }
    $pop->quit();

    ld_log( _message('WRN0205', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
    return $SERVICE_UP;
}

# check_imap
# IMAP service health check.
# Connect IMAP server and login if user-pass specified.
sub check_imap {
    require Mail::IMAPClient;
    my ($v, $r) = @_;
    my $status = get_status([[$v, $r]]);

    my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};

    ld_debug(2, "Checking imap server=$r->{server}{ip} port=$port");
    my $debug_flag = $DEBUG_LEVEL ? 1 : 0;

    my $imap;
    {
        local $SIG{ALRM} = sub { die "Connection timeout\n"; };
        eval {
            alarm $v->{negotiatetimeout};
            $imap = Mail::IMAPClient->new(
                Server   => $r->{server}{ip},
                Port     => $port,
                Timeout  => $v->{negotiatetimeout},
                Debug    => $debug_flag,
            );
            alarm 0;
        };
        alarm 0;
        if ($EVAL_ERROR) {
            ld_log( _message('WRN1403', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
            return $SERVICE_DOWN;
        }
    }
    if (!$imap) {
        ld_log( _message('WRN1401', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }

    if ( defined $v->{login} && defined $v->{passwd} && $v->{login} ne q{} ) {
        $imap->User( $v->{login} );
        $imap->Password( $v->{passwd} );
        my $authres = $imap->login();
        if (!$authres) {
            ld_log( _message('WRN1402', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
            $imap->logout();
            return $SERVICE_DOWN;
        }
    }
    $imap->logout();

    ld_log( _message('WRN0206', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
    return $SERVICE_UP;
}

# check_ldap
# LDAP service health check.
# Connect LDAP server and search if base-DN specified by 'request'
sub check_ldap {
    require Net::LDAP;
    my ($v, $r) = @_;
    my $status = get_status([[$v, $r]]);

    my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};

    ld_debug(2, "Checking ldap server=$r->{server}{ip} port=$port");
    my $debug_flag = $DEBUG_LEVEL ? 15 : 0;

    my $ldap = Net::LDAP->new(
        $r->{server}{ip},
        port    => $port,
        timeout => $v->{negotiatetimeout},
        debug   => $debug_flag,
    );
    if (!$ldap) {
        ld_log( _message('WRN1501', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }

    my $mesg;
    {
        local $SIG{ALRM} = sub { die "Connection timeout\n"; };
        eval {
            alarm $v->{negotiatetimeout};
            $mesg = $ldap->bind;
            alarm 0;
        };
        alarm 0;
        if ($EVAL_ERROR) {
            ld_log( _message('WRN1502', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
            return $SERVICE_DOWN;
        }
    }
    if ($mesg->is_error) {
        ld_log( _message('WRN1503', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }

    if ( defined $r->{request} && $r->{request} ne q{} ) {
        ld_debug( 4, "Base : " . $r->{request} );
        my $result = $ldap->search(
            base   => $r->{request},
            scope  => 'base',
            filter => '(objectClass=*)',
        );
    
        if ($result->count != 1) {
            ld_log( _message('WRN1504', $result->count, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
            $ldap->unbind;
            return $SERVICE_DOWN;
        }
    
        if ( defined $r->{receive} ) {
            my $href       = $result->as_struct;
            my @arrayOfDNs = keys %$href;
            my $recstr = $r->{receive};
            if ($recstr =~ /.+/ && $arrayOfDNs[0] !~ /$recstr/) {
                ld_log( _message('WRN1505', $recstr, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
                $ldap->unbind;
                return $SERVICE_DOWN;
            }
        }
    }
    $ldap->unbind;

    ld_log( _message('WRN0207', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
    return $SERVICE_UP;
}

# check_nntp
# NNTP service health check.
# Connect NNTP server and check response start with '2**'
sub check_nntp {
    require IO::Socket;
    require IO::Select;
    my ($v, $r) = @_;
    my $status = get_status([[$v, $r]]);

    my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};

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

    my $sock = ld_open_socket( $r->{server}{ip}, $port, $v->{protocol}, $v->{negotiatetimeout} );
    if (!$sock) {
        ld_log( _message('WRN1601', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }

    ld_debug(3, "Connected to $r->{server}{ip} (port $port)");
    my $select = IO::Select->new();
    $select->add($sock);
    if ( !defined $select->can_read( $v->{negotiatetimeout} ) ) {
        ld_log( _message('WRN1602', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        $select->remove($sock);
        $sock->close;
        return $SERVICE_DOWN;
    }

    my $buf;
    sysread $sock, $buf, 64;
    $select->remove($sock);
    $sock->close;
    my ($response) = split /[\r\n]/, $buf;

    if ($response !~ /^2/) {
        ld_log( _message('WRN1603', $response, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }

    ld_log( _message('WRN0208', $response, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
    return $SERVICE_UP;
}

# check_mysql
# MySQL service health check.
# call check_sql and use MySQL driver
sub check_mysql {
    return check_sql(@_, 'mysql', 'database');
}

# check_pgsql
# PostgreSQL service health check.
# call check_sql and use PostgreSQL driver
sub check_pgsql {
    return check_sql(@_, 'Pg', 'dbname');
}

# check_sql
# DBI service health check.
# Login DB and send query if query specified by 'request', check result row number same as 'receive'
sub check_sql {
    require DBI;
    my ($v, $r, $dbd, $dbname) = @_;
    my $status = get_status([[$v, $r]]);

    my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};

    if ( !defined $v->{login} || !defined $v->{passwd} || !defined $v->{database} ||
           $v->{login} eq q{} || $v->{database} eq q{} ) {
        ld_log( _message('WRN1701', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }

    ld_debug(2, "Checking $v->{server}{ip} server=$r->{server}{ip} port=$port\n");

    my $mask = POSIX::SigSet->new(SIGALRM);
    my $action = POSIX::SigAction->new(
        sub { die "Connection timeout\n" },
        $mask,
    );
    my $oldaction = POSIX::SigAction->new();
    sigaction(SIGALRM, $action, $oldaction);

    my $dbh;
    eval {
        alarm $v->{negotiatetimeout};

        DBI->trace(15) if $DEBUG_LEVEL;
        $dbh = DBI->connect( "dbi:$dbd:$dbname=$v->{database};host=$r->{server}{ip};port=$port", $v->{login}, $v->{passwd} );
        DBI->trace(0);

        if (!defined $dbh) {
            alarm 0;
            sigaction(SIGALRM, $oldaction);
            ld_log( _message('WRN1702', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
            die;
        }

        local $dbh->{TraceLevel} = $DEBUG_LEVEL ? 15 : 0;

        my $rows = 0;
    
        if ( defined $r->{request} && $r->{request} ne q{} ) {
            my $sth  = $dbh->prepare( $r->{request} );
            $rows = $sth->execute;
            $sth->finish;
        }
    
        $dbh->disconnect;
    
        alarm 0;
        sigaction(SIGALRM, $oldaction);

        if ( defined $r->{request} && $r->{request} ne q{} ) {
            ld_debug(4, "Database search returned $rows rows");
            if ($rows == 0) {
                ld_log( _message('WRN1703', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
                die;
            }
            # If user defined a receive string (number of rows returned), only do
            # the check if the previous fetchall_arrayref succeeded.
            if (defined $r->{receive} && $r->{receive} =~ /^\d+$/) {
                # Receive string specifies an exact number of rows
                if ( $rows ne $r->{receive} ) {
                    ld_log( _message('WRN1704', $r->{receive}, $rows, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
                    die;
                }
            }
        }
    };
    alarm 0;
    sigaction(SIGALRM, $oldaction);
    if ($EVAL_ERROR) {
        if ($EVAL_ERROR eq "Connection timeout\n") {
            ld_log( _message('WRN1705', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        }
        return $SERVICE_DOWN;
    }

    ld_log( _message('WRN0209', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
    return $SERVICE_UP;
}

# check_connect
# Connect service health check.
# Just connect port and close.
sub check_connect {
    my ($v, $r) = @_;
    my $status = get_status([[$v, $r]]);

    my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};

    ld_debug(2, "Checking connect: real server=$r->{server}{ip}:$port");

    my $sock = ld_open_socket( $r->{server}{ip}, $port, $v->{protocol}, $v->{checktimeout} );
    if (!defined $sock) {
        ld_log( _message('WRN3201', $ERRNO, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }
    close($sock);

    ld_debug(3, "Connected to: (port $port)");

    ld_log( _message('WRN0210', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
    return $SERVICE_UP;
}

# check_sip
# SIP service health check.
# Send SIP OPTIONS request and check 200 response
sub check_sip {
    my ($v, $r) = @_;
    my $status = get_status([[$v, $r]]);

    my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};

    ld_debug(2, "Checking sip server=$r->{server}{ip} port=$port");

    if ( !defined $v->{login} ) {
        ld_log( _message('WRN1801', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }

    my $sock = ld_open_socket( $r->{server}{ip}, $port, $v->{protocol}, $v->{negotiatetimeout} );
    if (!defined $sock) {
        ld_log( _message('WRN1802', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }

    my $sip_s_addr = $sock->sockhost;
    my $sip_s_port = $sock->sockport;

    ld_debug(3, "Connected from $sip_s_addr:$sip_s_port to " . $r->{server} . ":$port");

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

    ld_debug(3, "Request:\n$request");

    my $response;
    eval {
        local $SIG{__DIE__} = 'DEFAULT';
        local $SIG{ALRM   } = sub { die "Connection timeout\n"; };
        ld_debug(4, "Timeout is $v->{negotiatetimeout}");
        alarm $v->{negotiatetimeout};

        print {$sock} $request;
        $response = <$sock>;
        close $sock;
        alarm 0;

        ld_debug(3, "Response:\n$response");

        if ( $response !~ m{^SIP/2\.0 200 OK} ) {
            ld_log( _message('WRN1803', $response, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
            die;
        }
    };
    alarm 0;
    if ($EVAL_ERROR) {
        if ($EVAL_ERROR eq "Connection timeout\n") {
            ld_log( _message('WRN1804', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        }
        return $SERVICE_DOWN;
    }

    ld_log( _message('WRN0211', $response, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
    return $SERVICE_UP;
}

# check_ftp
# FTP service health check.
# Login server and get file if 'request' specified, and check file include 'receive' string
sub check_ftp {
    require Net::FTP;
    my ($v, $r) = @_;
    my $status = get_status([[$v, $r]]);

    my $ip_port = get_ip_port($r, $v->{checkport});

    ld_debug(2, "Checking ftp server=$ip_port");
    my $debug_flag = $DEBUG_LEVEL ? 1 : 0;

    if ( !defined $v->{login} || !defined $v->{passwd} || $v->{login} eq q{} ) {
        ld_log( _message('WRN1901', $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }

    my $ftp = Net::FTP->new(
            $ip_port,
            Timeout => $v->{negotiatetimeout},
            Passive => 1,
            Debug   => $debug_flag,
         );
    if (!defined $ftp) {
        ld_log( _message('WRN1902', $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }
    if ( !$ftp->login( $v->{login}, $v->{passwd} ) ) {
        ld_log( _message('WRN1903', $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
        $ftp->quit();
        return $SERVICE_DOWN;
    }
    if ( !$ftp->cwd('/') ) {
        ld_log( _message('WRN1904', $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
        $ftp->quit();
        return $SERVICE_DOWN;
    }
    if ( $r->{request} ) {
        my $fail_flag = 0;
        eval {
            local $SIG{__DIE__} = 'DEFAULT';
            local $SIG{ALRM   } = sub { die "Connection timeout\n"; };
            alarm $v->{negotiatetimeout};

            open my $tmp, '+>', undef;
            $ftp->binary();
            if ( !$ftp->get( $r->{request}, *$tmp ) ) {
                alarm 0;
                ld_log( _message('WRN1905', $r->{request}, $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
                close $tmp;
                $ftp->quit();
                $fail_flag = 1;
            }
            elsif ( $r->{receive} ) {
                seek $tmp, 0, 0;
                local $/;
                my $memory = <$tmp>;
                close $tmp;
                if ($memory !~ /$r->{receive}/) {
                    alarm 0;
                    $ftp->quit();
                    ld_log( _message('WRN1906', $r->{receive}, $r->{request}, $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
                    $fail_flag = 1;
                }
            }
        };
        alarm 0;
        if ($EVAL_ERROR) {
            $ftp->quit();
            my $error_message = $EVAL_ERROR;
            $error_message =~ s/[\r\n]//g;
            if ($error_message eq 'Connection timeout') {
                ld_log( _message('WRN1908', $v->{negotiatetimeout}, $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
            }
            else {
                ld_log( _message('WRN1907', $error_message, $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
            }
            return $SERVICE_DOWN;
        }
        if ($fail_flag) {
            $ftp->quit();
            return $SERVICE_DOWN;
        }
    }
    $ftp->quit();

    ld_log( _message('WRN0212', $ip_port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
    return $SERVICE_UP;
}

# check_dns
# DNS service health check.
# Connect server and search 'request' A or PTR record and check result include 'response' string 
sub check_dns {
    my ($v, $r) = @_;
    my $status = get_status([[$v, $r]]);

    my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port}; 

    {
        # Net::DNS makes ungaurded calls to eval
        # which throw a fatal exception if they fail
        local $SIG{__DIE__} = 'DEFAULT';
        require Net::DNS;
    }
    my $res = Net::DNS::Resolver->new();

    if ($DEBUG_LEVEL) {
        $res->debug(1);
    }

    if ( !defined $r->{request} || $r->{request} eq q{} || !defined $r->{receive} || $r->{receive} eq q{} ) {
        ld_log( _message('WRN2001', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }
    ld_debug( 2, qq(Checking dns: request="$r->{request}" receive="$r->{receive}"\n) );

    my $packet;
    eval {
        local $SIG{__DIE__} = 'DEFAULT';
        local $SIG{ALRM   } = sub { die "Connection timeout\n"; };
        alarm $v->{negotiatetimeout};
        $res->nameservers( $r->{server}{ip} );
        $res->port($port);
        $packet = $res->search( $r->{request} );
        alarm 0;
    };
    alarm 0;
    if ($EVAL_ERROR) {
        if ($EVAL_ERROR eq "Connection timeout\n") {
            ld_log( _message('WRN2002', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        }
        else {
            ld_log( _message('WRN2003', $EVAL_ERROR, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        }
        return $SERVICE_DOWN;
    }
    if (!$packet) {
        ld_log( _message('WRN2004', $r->{request}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }

    my $match = 0;
    for my $rr ($packet->answer) {
        if (   ( $rr->type eq 'A'   && $rr->address  eq $r->{receive} )
            || ( $rr->type eq 'PTR' && $rr->ptrdname eq $r->{receive} ) ) {
            $match = 1;
            last;
        }
    }
    if (!$match) {
        ld_log( _message('WRN2005', $r->{receive}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }

    ld_log( _message('WRN0213', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
    return $SERVICE_UP;
}

# check_ping
# ICMP ping service health check.
# Ping server and check response.
sub check_ping {
    require Net::Ping;
    my ($v, $r) = @_;
    my $status = get_status([[$v, $r]]);

    ld_debug( 2, qq(Checking ping: host="$r->{server}{ip}" checktimeout="$v->{checktimeout}"\n) );

    my $p = Net::Ping->new('icmp', 1, 64);
    if ( !$p->ping( $r->{server}{ip}, $v->{checktimeout} ) ) {
        ld_log( _message('WRN3101', $v->{checktimeout}, $r->{server}{ip}) ) if (!defined $status || $status eq $SERVICE_UP);
        return $SERVICE_DOWN;
    }

    ld_log( _message('WRN0214', $r->{server}{ip}) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
    return $SERVICE_UP;
}

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

# check_off
# Check nothing and always return $SERVICE_DOWN
sub check_off {
    my ($v, $r) = @_;
    return $SERVICE_DOWN;
}

# check_on
# Check nothing and always return $SERVICE_UP
sub check_on {
    my ($v, $r) = @_;
    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_r_list: virtual and real pair list
#                [ [$v, $r], [$v, $r] ... ]
#      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_list, $state) = @_;

    if (defined $state && $state eq 'up') {
        _service_up($v_r_list);
    }
    elsif (defined $state && $state eq 'down') {
        _service_down($v_r_list);
    }
}

# _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_r_list: virtual and real pair list
#                [ [$v, $r], [$v, $r] ... ]
# post: real service is taken up from the respective virtual service
#       if it is inactive
# return: none
sub _service_up {
    my $v_r_list = shift;
    if ( !_status_up($v_r_list) ) {
        return;
    }

    for my $v_r_pair (@$v_r_list) {
        my ($v, $r) = @$v_r_pair;
        _restore_service($v, $r, 'real');
        fallback_off($v);
    }
}

# _service_down
# Bring a real service down if it is up
# Should be called by service_set only
# I.e. if you want to change the state of a real server call service_set.
#      If you call this function directly then l7directord will lose track
#      of the state of real servers.
# pre: v_r_list: virtual and real pair list
#                [ [$v, $r], [$v, $r] ... ]
# post: real service is taken down from the respective virtual service
#       if it is active
# return: none
sub _service_down {
    my $v_r_list = shift;
    if ( !_status_down($v_r_list) ) {
        return;
    }

    for my $v_r_pair (@$v_r_list) {
        my ($v, $r) = @$v_r_pair;
        _remove_service($v, $r, 'real');
        fallback_on($v);
    }
}

# _status_up
# Set the status of a server as up
# Should only be called from _service_up or fallback_on
sub _status_up {
    my ($v_r_list, $is_fallback) = @_;
    if (!defined $v_r_list) {
        return 0;
    }

    if (!$is_fallback) {
        my $current_status = get_status($v_r_list);
        if (defined $current_status && $current_status eq $SERVICE_UP) {
            return 0;
        }
    
        my $id = get_health_check_id_str( @{ $v_r_list->[0] } );
        if (!defined $id) {
            ld_log( _message('ERR0503') );
            return 0;
        }
        $HEALTH_CHECK{$id}{status} = $SERVICE_UP;
    
        return 1;
    }
    else {
        my $current_service = ld_read_l7vsadm();
        if (!defined $current_service) {
            ld_log( _message('FTL0201') );
            return 0;
        }
        my $vid = get_virtual_id_str( $v_r_list->[0][0] );
        if ( exists $current_service->{$vid} ) {
            # no real server
            if ( !defined $current_service->{$vid} ) {
                return 1;
            }
            my $weight = 0;
            # all real server's weight are zero.
            for my $real ( keys %{ $current_service->{$vid} } ) {
                # already added fallback server.
                if ( $real eq get_ip_port( $v_r_list->[0][1] ) ) {
                    return 0;
                }
                $weight += $current_service->{$vid}{$real}{weight};
            }
            if ($weight == 0) {
                return 1;
            }
        }
        return 0;
    }
}

# _status_down
# Set the status of a server as down
# Should only be called from _service_down or _ld_stop
sub _status_down {
    my ($v_r_list, $is_fallback) = (@_);
    if (!defined $v_r_list) {
        return 0;
    }

    if (!$is_fallback) {
        my $current_status = get_status($v_r_list);
        if ($current_status && $current_status eq $SERVICE_DOWN) {
            return 0;
        }
    
        my $id = get_health_check_id_str( @{ $v_r_list->[0] } );
        if (!defined $id) {
            ld_log( _message('ERR0503') );
            return 0;
        }
        $HEALTH_CHECK{$id}{status} = $SERVICE_DOWN;
    
        return 1;
    }
    else {
        my $current_service = ld_read_l7vsadm();
        if (!defined $current_service) {
            ld_log( _message('FTL0201') );
            return 0;
        }
        my $vid = get_virtual_id_str( $v_r_list->[0][0] );
        if ( defined $current_service->{$vid} ) {
            my $weight = 0;
            my $fallback_exist = 0;
            # any real server has weight.
            for my $real ( keys %{ $current_service->{$vid} } ) {
                if ( $real eq get_ip_port( $v_r_list->[0][1] ) ) {
                    $fallback_exist = 1;
                }
                $weight += $current_service->{$vid}{$real}{weight};
            }
            if ($fallback_exist && $weight) {
                return 1;
            }
        }
        return 0;
    }
}

# get_status
# Get health check server status
# return $SERVICE_UP / $SERVICE_DOWN
sub get_status {
    my $v_r_list = shift;

    my $id = get_health_check_id_str( @{ $v_r_list->[0] } );
    if (!defined $id) {
        ld_log( _message('ERR0503') );
        return 0;
    }
    return $HEALTH_CHECK{$id}{status};
}

# _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, $r, $tag) = @_;
    if (!defined $v || !defined $r) {
        ld_log( _message('ERR0501') );
        return;
    }

    my $vip_id = get_virtual_id_str($v);
    if (!defined $vip_id) {
        ld_log( _message('ERR0502') );
        return;
    }
    my $oldsrv = ld_read_l7vsadm();
    if (!defined $oldsrv) {
        ld_log( _message('FTL0201') );
        return;
    }

    if ( !exists $oldsrv->{$vip_id} ) {
        ld_log( _message( 'ERR0208', get_ip_port($r), get_ip_port($v) ) );
        return;
    }

    # quiescent check
    my $is_quiescent = 0;
    if (!defined $tag || $tag ne 'fallback') {
        if ( defined $v->{quiescent} && $v->{quiescent} ) {
            $is_quiescent = 1;
        }
    }

    my $or = $oldsrv->{$vip_id}{ get_ip_port($r) };
    # already removed server
    if (!defined $or && !$is_quiescent) {
        my $module_key = $v->{module}{name} . q{ } . $v->{module}{key};
        ld_log( _message( 'ERR0210', get_ip_port($r), get_ip_port($v), $module_key ) );
        return;
    }
    # already quiescent server
    if ( defined $or && $is_quiescent && $or->{weight} == 0 &&
         $or->{option}{forward} eq $r->{option}{forward} ) {
        my $module_key = $v->{module}{name} . q{ } . $v->{module}{key};
        ld_log( _message( 'ERR0211', get_ip_port($r), get_ip_port($v), $module_key ) );
        return;
    }

    if ($is_quiescent) {
        if (defined $or) {
            ld_edit_real($v, $r, 0);
        }
        else {
            ld_add_real($v, $r, 0);
        }
        if (!defined $tag || $tag eq 'real') {
            ld_log( _message( 'INF0303', get_ip_port($r) ) );
        }
        elsif ($tag eq 'fallback') {
            ld_log( _message( 'INF0304', get_ip_port($r) ) );
        } 
    }
    else {
        ld_delete_real($v, $r);
        if (!defined $tag || $tag eq 'real') {
            ld_log( _message( 'INF0305', get_ip_port($r) ) );
        }
        elsif ($tag eq 'fallback') {
            ld_log( _message( 'INF0306', get_ip_port($r) ) );
        } 
    }

    if ( defined $v->{realdowncallback} && $r->{healthchecked} ) {
        system_wrapper( $v->{realdowncallback}, get_ip_port($r) );
        ld_log( _message( 'INF0501',  $v->{realdowncallback}, get_ip_port($r) ) );
    }
    $r->{healthchecked} = 1;
}

# _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
#      r: reference to real server to restore.
#      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, $r, $tag) = @_;
    if (!defined $v || !defined $r) {
        ld_log( _message('ERR0501') );
        return;
    }

    my $vip_id = get_virtual_id_str($v);
    if (!defined $vip_id) {
        ld_log( _message('ERR0502') );
        return;
    }
    my $oldsrv = ld_read_l7vsadm();
    if (!defined $oldsrv) {
        ld_log( _message('FTL0201') );
        return;
    }

    if ( !exists $oldsrv->{$vip_id} ) {
        ld_log( _message( 'ERR0207', get_ip_port($r), get_ip_port($v) ) );
        return;
    }

    my $or = $oldsrv->{$vip_id}{ get_ip_port($r) };
    # already completely same server exist
    if ( defined $or &&
         $or->{weight} eq $r->{weight} &&
         $or->{option}{forward} eq $r->{option}{forward} ) {
        my $module_key = $v->{module}{name} . q{ } . $v->{module}{key};
        ld_log( _message( 'ERR0209', get_ip_port($r), get_ip_port($v), $module_key ) );
        return;
    }

    if (defined $or) {
        ld_edit_real( $v, $r, $r->{weight} );
    }
    else {
        ld_add_real( $v, $r, $r->{weight} );
    }

    if (!defined $tag || $tag eq 'real') {
        ld_log( _message( 'INF0301', get_ip_port($r) ) );
    }
    elsif ($tag eq 'fallback') {
        ld_log( _message( 'INF0302', get_ip_port($r) ) );
    } 

    if ( defined $v->{realrecovercallback} && $r->{healthchecked} ){
        system_wrapper( $v->{realrecovercallback}, get_ip_port($r) );
        ld_log( _message( 'INF0502',  $v->{realrecovercallback}, get_ip_port($r) ) );
    }
    $r->{healthchecked} = 1;
}

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

    my $fallback = fallback_find($v);
    if (defined $fallback) {
        my $v_r_list = [ [ $v, $fallback->{tcp} ] ];
        if ( _status_up($v_r_list, 'fallback') ) {
            _restore_service($v, $fallback->{tcp}, '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 = shift;

    my $fallback = fallback_find($v);
    if (defined $fallback) {
        my $v_r_list = [ [ $v, $fallback->{tcp} ] ];
        if ( _status_down($v_r_list, 'fallback') ) {
            _remove_service($v, $fallback->{tcp}, 'fallback');
        }
    }
}

# fallback_find
# Determine the fallback for a virtual service
# pre: v: reference to a virtual service
# post: none
# return: $v->{fallback} if defined
#         else undef
sub fallback_find {
    my $v = shift;
    if (!defined $v) {
        ld_log( _message('ERR0501') );
        return;
    }
    return $v->{fallback};
}

# check_cfgfile
# Check configfile change.
# pre: none
# post: check configfile size, and then check md5 sum
# return: 1 if notice file change
#         0 if not notice or not change
sub check_cfgfile {
    if (!defined $CONFIG_FILE{path}) {
        ld_log( _message('FTL0102') );
        return 0;
    }

    my $mtime = (stat $CONFIG_FILE{path})[9];
    if (!defined $mtime) {
        ld_log( _message( 'ERR0410', $CONFIG_FILE{path} ) );
        return 0;
    }

    if ( defined $CONFIG_FILE{stattime} && $mtime == $CONFIG_FILE{stattime} ) {
        # file mtime is not change
        return 0;
    }
    $CONFIG_FILE{stattime} = $mtime;

    my $digest = undef;;
    eval {
        require Digest::MD5;

        my $ctx = Digest::MD5->new();
        open my $config, '<', $CONFIG_FILE{path};
        $ctx->addfile($config);
        $digest = $ctx->hexdigest;
        close $config;
    };
    if ($EVAL_ERROR) {
        ld_log( _message( 'ERR0407', $CONFIG_FILE{path} ) );
        return 0;
    }

    if (defined $CONFIG_FILE{checksum} && $digest && 
                $CONFIG_FILE{checksum} ne $digest ) {
        ld_log( _message('WRN0101', $CONFIG_FILE{path}) );
        $CONFIG_FILE{checksum} = $digest;

        if ( defined $CONFIG{callback} && -x $CONFIG{callback} ) {
            system_wrapper( $CONFIG{callback} . q{ } . $CONFIG_FILE{path} );
            ld_log( _message( 'INF0503',  $CONFIG{callback}, $CONFIG_FILE{path} ) );
        }

        if ( $CONFIG{autoreload} ) {
            ld_log( _message('WRN0102') );
            return 1;
        }
        else {
            ld_log( _message('WRN0103') );
            return 0;
        }
    }

    $CONFIG_FILE{checksum} = $digest;
    return 0;
}

# ld_openlog
# Open logger
# make log rotation work
# pre: log setting
# 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 {
    my $log_config = shift;
    if (!defined $log_config) {
        ld_log( _message('ERR0501') );
        return 1;
    }

    if ( $DEBUG_LEVEL > 0 or $CONFIG{supervised} ) {
        # Instantly do nothing
        return 0;
    }

    if ( $log_config =~ m{^/}) {
        # Open and close the file as a test.
        # We open the file each time we want to log to it
        eval {
            open my $log_file, ">>", $log_config;
            close $log_file;
        };
        if ($EVAL_ERROR) {
            ld_log( _message('ERR0118', $log_config) );
            return 1;
        }
    }
    else {
        # Assume $log_config is a logfacility, log to syslog
        setlogsock("unix");
        openlog("l7directord", "pid", $log_config);
        # FIXME "closelog" not found
    }

    $PROC_STAT{log_opened} = 1;
    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 = shift;
    if (!defined $message) {
        ld_log( _message('ERR0501') );
        return 1;
    }

    ld_debug(2, $message);
    chomp $message;

    if ( !$PROC_STAT{log_opened} ) {
        return 1;
    }

    my $now = localtime();
    my $line_header = sprintf "[%s|%d] ", $now, $PROC_STAT{pid};
    $message =~ s/^/$line_header/mg;

    if ( $CONFIG{supervised} ) {
        print {*STDOUT} $message . "\n";
    }
    elsif ( $CONFIG{logfile} =~ m{^/} ) {
        eval {
            open my $log_file, '>>', $CONFIG{logfile};
            flock $log_file, 2; # LOCK_EX
            print {$log_file} $message . "\n";
            close $log_file;
        };
        if ($EVAL_ERROR) {
            print {*STDERR} _message_only( 'FTL0103', $CONFIG{logfile}, $message ) . "\n";
            return 1;
        }
    }
    else {
        # Assume LOGFILE 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_LEVEL >= priority
# return: none
sub ld_debug {
    my ($priority, $message) = @_;

    if (defined $priority && $priority =~ /^\d+$/ &&
        defined $message  && $DEBUG_LEVEL >= $priority) {
        chomp $message;
        $message =~ s/^/DEBUG[$priority]: /mg;
        print {*STDERR} $message . "\n";
    }
}

# command_wrapper
# Wrapper around command(qx) to get output
# pre: command to execute
# post: execute command and if it returns non-zero a failure
#       message is logged
# return: return value of command, and output
sub command_wrapper {
    my $command = shift;

    if ($DEBUG_LEVEL > 2) {
        ld_log( _message( 'INF0506', $command) );
    }

    $command =~ s/([{}\\])/\\$1/g;
    my $output = qx($command);
    if ($CHILD_ERROR != 0) {
        ld_log( _message('ERR0303', $command, $CHILD_ERROR) );
    }
    return ($CHILD_ERROR, $output);
}

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

    if ($DEBUG_LEVEL > 2) {
        ld_log( _message( 'INF0504', join(q{ }, @args) ) );
    }
    my $status = system(@args);
    if ($DEBUG_LEVEL > 2) {
        if ($status != 0) {
            ld_log( _message('ERR0301', join(q{ }, @args), $status) );
        }
    }
    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 = @_;

    if ($DEBUG_LEVEL > 2) {
        ld_log( _message( 'INF0505', join(q{ }, @args) ) );
    }
    my $status = exec(@args);
    if (!$status) {
        ld_log( _message('ERR0302', join(q{ }, @args), $status) );
    }
    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_LEVEL >=2 errors are logged
# return:  0 on success
#         -1 on error
sub ld_rm_file {
    my $filename = shift;
    if (!defined $filename) {
        ld_log( _message('ERR0411') );
        return -1;
    }
    if (-d $filename) {
        ld_log( _message('ERR0401', $filename) );
        return -1;
    }
    if (!-e $filename) {
        ld_log( _message('ERR0402', $filename) );
        return -1;
    }
    my $status = unlink $filename;
    if ($status != 1) {
        ld_log( _message('ERR0403', $filename, $ERRNO) );
        return -1;
    }
    return 0;
}

# 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 = shift;
    if (!defined $alleged_octet || $alleged_octet !~ /^\d+$/ || $alleged_octet > 255) {
        ld_log( _message('ERR0501') );
        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 = shift;

    # If we don't have four, . delimited numbers then we have no hope
    if (!defined $alleged_ip || $alleged_ip !~ m/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/) {
        ld_log( _message('ERR0501') );
        return 0;
    }

    # Each octet must be >=0 and <=255
    is_octet($1) or return 0;
    is_octet($2) or return 0;
    is_octet($3) or return 0;
    is_octet($4) or 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 = shift;

    if ( !is_ip($ip_address) ) {
        return -1;
    }
    my ($oct1, $oct2, $oct3, $oct4)
        = $ip_address =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/;

    my $result = ($oct1 << 24) + ($oct2 << 16) + ($oct3 << 8) + $oct4;
    return $result;
}

# int_to_ip
# Turn an IP address given as an integer into a dotted quad
# pre: ip_address: integer representation of IP address
# post: Decimal is converted to a dotted quad
# return: string representing IP address
sub int_to_ip {
    my $ip_address = shift;
    if (!defined $ip_address || $ip_address !~ /^\d+$/) {
        ld_log( _message('ERR0501') );
        return;
    }

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

# get_ip_port
# Get the service for a virtual or a real
# pre: host: virtual or real to get the service for
# post: none
# return: ip_address:port
sub get_ip_port {
    my ($host, $checkport) = @_;
    my $server = defined $host && defined $host->{server} && defined $host->{server}{ip}
                    ? $host->{server}{ip  } : q{};
    my $port   = defined $checkport ? $checkport
               : defined $host && defined $host->{server} && defined $host->{server}{port}
                    ? $host->{server}{port} : q{};

    my $ip_port = $server ne q{} && $port ne q{} ? "$server:$port" : q{};
    return $ip_port;
}

# get_health_check_id_str
# Get an id string for a health check process
# pre: r: Real service.
#      v: Virtual service
# post: none
# return: Id string for the health check process
sub get_health_check_id_str {
    my ($v, $r) = @_;
    if ( !defined $v || !defined $r || !defined $r->{server} ) {
        ld_log( _message('ERR0501') );
        return;
    }

    my $ip   = defined $r->{server}{ip  } ? $r->{server}{ip  } : q{};
    my $port = defined $v->{checkport   } ? $v->{checkport   } :
               defined $r->{server}{port} ? $r->{server}{port} : q{};
    my $checktype    = defined $v->{checktype   } ? $v->{checktype   } : q{};
    my $service      = defined $v->{service     } ? $v->{service     } : q{};
    my $protocol     = defined $v->{protocol    } ? $v->{protocol    } : q{};
    my $num_connects = defined $v->{num_connects} ? $v->{num_connects} : q{};
    my $request      = defined $r->{request     } ? $r->{request     } : q{};
    my $receive      = defined $r->{receive     } ? $r->{receive     } : q{};
    my $httpmethod   = defined $v->{httpmethod  } ? $v->{httpmethod  } : q{};
    my $virtualhost  = defined $v->{virtualhost } ? $v->{virtualhost } : q{};
    my $login        = defined $v->{login       } ? $v->{login       } : q{};
    my $password     = defined $v->{passwd      } ? $v->{passwd      } : q{};
    my $database     = defined $v->{database    } ? $v->{database    } : q{};
    my $customcheck  = defined $v->{customcheck } ? $v->{customcheck } : q{};
    my $checkinterval    = defined $v->{checkinterval    } ? $v->{checkinterval    } : q{};
    my $checkcount       = defined $v->{checkcount       } ? $v->{checkcount       } : q{};
    my $checktimeout     = defined $v->{checktimeout     } ? $v->{checktimeout     } : q{};
    my $negotiatetimeout = defined $v->{negotiatetimeout } ? $v->{negotiatetimeout } : q{};
    my $retryinterval    = defined $v->{retryinterval    } ? $v->{retryinterval    } : q{};

    # FIXME SHOULD change separator. (request, receive, login, passwd ,database may include ':')
    my $id = "$ip:$port:$checktype:$service:$protocol:$num_connects:$request:$receive:" .
             "$httpmethod:$virtualhost:$login:$password:$database:$customcheck:" .
             "$checkinterval:$checkcount:$checktimeout:$negotiatetimeout:$retryinterval";

    return $id;
}

# 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 = shift;
    if ( !defined $v || !defined $v->{module} ) {
        ld_log( _message('ERR0501') );
        return;
    }

    my $ip_port     = get_ip_port($v);
    my $protocol    = defined $v->{protocol    } ? $v->{protocol    } : q{};
    my $module_name = defined $v->{module}{name} ? $v->{module}{name} : q{};
    my $module_key  = defined $v->{module}{key } ? $v->{module}{key } : q{};

    my $id = "$protocol:$ip_port:$module_name $module_key";
    $id =~ s/ +$//;

    return $id;
    # [cf] id = "tcp:127.0.0.1:80:cinsert --cookie-name 'monkey'"
}

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

    if (defined $forward && $forward =~ /^masq$/i) {
        return '-m';
    }
    return q{};
}

# 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_LEVEL>2 then
#       message logged.
#       Programme exits with exit_status
# return: does not return
sub ld_exit {
    my ($exit_status, $message) = @_;
    if (defined $exit_status && defined $message) {
        ld_log( _message('INF0006', $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
sub ld_open_socket {
    require IO::Socket::INET;
    my ($remote, $port, $protocol, $timeout) = @_;

    my $sock_handle = IO::Socket::INET->new(
            PeerAddr => $remote,
            PeerPort => $port,
            Proto    => $protocol,
            Timeout  => $timeout,
        );
    return $sock_handle;
}

# 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.
sub ld_daemon {
    ld_daemon_become_child();

    if (POSIX::setsid() < 0) {
        ld_exit( 7, _message_only('ERR0702') );
    }

    ld_daemon_become_child();

    if (chdir('/') < 0) {
        ld_exit( 8, _message_only('ERR0703') );
    }

    close *STDIN;
    close *STDOUT;
    close *STDERR;

    eval { open  *STDIN, '<', '/dev/null'; };
    ld_exit(9, _message_only('ERR0704') ) if ($EVAL_ERROR);
    eval { open *STDOUT, '>>', '/dev/console'; };
    ld_exit(10, _message_only('ERR0705') ) if ($EVAL_ERROR);
    eval { open *STDERR, '>>', '/dev/console'; };
    ld_exit(10, _message_only('ERR0705') ) if ($EVAL_ERROR);
}

# 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)
sub ld_daemon_become_child {
    my $status = fork();
    $PROC_STAT{pid} = $PID;

    if ($status < 0) {
        ld_exit( 6, _message_only('ERR0701', $ERRNO) );
    }
    if ($status > 0) {
        ld_exit( 0, _message_only('INF0005') );
    }
}

# 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 = shift;
    $name = q{} if !defined $name;
    my $addrs = ( gethostbyname($name) )[4] or return;
    return Socket::inet_ntoa($addrs);
}

# 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) = @_;
    $name     = q{} if !defined $name;
    $protocol = q{} if !defined $protocol;

    if ($name =~ /^\d+$/) {
        if ($name > 65535) {
            return;
        }
        return $name;
    }

    my $port = ( getservbyname($name, $protocol) )[2] or return;
    return $port;
}

# ld_gethostservbyname
# Wraper for ld_gethostbyname and ld_getservbyname. Given a server of the
# form ip_address|hostname:port|servicename return hash refs of ip_address and 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 => ip_address, port => port }
#         undef on error
sub ld_gethostservbyname {
    my ($hostserv, $protocol) = @_;

    if (!defined $hostserv || $hostserv !~ /
            ^
            (\d+\.\d+\.\d+\.\d+|[a-z0-9.-]+) # host or ip
            :                                # colon
            (\d+|[a-z0-9-]+)                 # serv or port
            $
        /ix) {
        return;
    }
    my $ip   = $1;
    my $port = $2;
    $ip   = ld_gethostbyname($ip)              or return;
    $port = ld_getservbyname($port, $protocol) or return;

    return {ip => $ip, port => $port};
}

# _message_only
# Create message only.
sub _message_only {
    my ($code, @message_args) = @_;

    my $message_list = {
        # health check process exit
        FTL0001 => "health_check argument is invalid. Exit this monitor process with status: 1",
        FTL0002 => "health_check argument pair, virtual or real structure is invalid. Exit this monitor process with status: 2",
        FTL0003 => "Detected down management process (pid: %s). Exit this monitor process with status: 3",
        # file fatal error
        FTL0101 => "l7vsadm file `%s' is not found or cannot execute.",
        FTL0102 => "Config file is not defined. So cannot check configuration change.",
        FTL0103 => "Cannot open logfile `%s'. Log message: `%s'",
        # command fatal error
        FTL0201 => "Result of read from l7vsadm is not defined.",

        # exit
        ERR0001 => "Initialization error: %s",
        ERR0002 => "Configuration error and exit.",
        # validation error
        ERR0101 => "Invalid value (set natural number) `%s'.",
        ERR0102 => "Invalid value (set `yes' or `no') `%s'.",
        ERR0103 => "Invalid value (set any word) `%s'.",
        ERR0104 => "Invalid value (set `custom', `connect', `negotiate', `ping', `off', `on' "
                 . "or positive number) `%s'.",
        ERR0105 => "Invalid value (set `lc', `rr' or `wrr') `%s'.",
        ERR0106 => "Invalid value (set `http', `https', `ftp', `smtp', `pop', `imap', "
                 . "`ldap', `nntp', `dns', `mysql', `pgsql', `sip', or `none') `%s'.",
        ERR0107 => "Invalid value (forwarding mode must be `masq') `%s'.",
        ERR0108 => "Invalid port number `%s'.",
        ERR0109 => "Invalid protocol (protocol must be `tcp') `%s'.",
        ERR0110 => "Invalid HTTP method (set `GET' or `HEAD') `%s'.",
        ERR0111 => "Invalid module (set `url', `pfilter', `ip', `sslid' or `sessionless') `%s'.",
        # ERR0111 => "Invalid module (set `cinsert', `cpassive', `crewrite', `url', `pfilter', `ip', `sslid' or `sessionless') `%s'.",
        ERR0112 => "Invalid module key option (`%s' module must set `%s' option) `%s'.",
        ERR0113 => "Invalid QoS value (set 0 or 1-999[KMG]. must specify unit(KMG)) `%s'.",
        ERR0114 => "Invalid address `%s'.",
        ERR0115 => "Invalid address range (first value(%s) must be less than or equal to the second value(%s)) `%s'.",
        ERR0116 => "File not found `%s'.",
        ERR0117 => "File not found or cannot execute `%s'.",
        ERR0118 => "Unable to open logfile `%s'.",
        ERR0119 => "Virtual section not found for `%s'.",
        ERR0120 => "Unknown config `%s'.",
        ERR0121 => "Configuration error. Reading file `%s' at line %d: %s",
        ERR0122 => "Caught exception during re-read config file and re-setup l7vsd. (message: %s) "
                 . "So config setting will be rollbacked.",
        ERR0123 => "`%s' is a required module for checking %s service.",
        # operate l7vsd error
        ERR0201 => "Failed to add virtual service to l7vsd: `%s %s', output: `%s'",
        ERR0202 => "Failed to edit virtual service on l7vsd: `%s %s', output: `%s'",
        ERR0203 => "Failed to delete virtual service from l7vsd: `%s %s', output: `%s'",
        ERR0204 => "Failed to add server to l7vsd: `%s' ( x `%s %s'), output: `%s'",
        ERR0205 => "Failed to edit server on l7vsd: `%s' ( x `%s %s'), output: `%s'",
        ERR0206 => "Failed to delete server from l7vsd: `%s' ( x `%s %s'), output: `%s'",
        ERR0207 => "Trying add server `%s', but virtual service `%s' is not found.",
        ERR0208 => "Trying delete server `%s', but virtual service `%s' is not found.",
        ERR0209 => "`%s' was already existed on l7vsd. ( x `%s %s')",
        ERR0210 => "`%s' was already deleted on l7vsd. ( x `%s %s')",
        ERR0211 => "`%s' was already changed to quiescent state on l7vsd. ( x `%s %s')",
        # command error
        ERR0301 => "Failed to system `%s' with return: %s",
        ERR0302 => "Failed to exec `%s' with return: %s",
        ERR0303 => "Failed to command `%s' with return: %s",
        # file error
        ERR0401 => "Failed to delete file `%s': `Is a directory'",
        ERR0402 => "Failed to delete file `%s': `No such file'",
        ERR0403 => "Failed to delete file `%s': `%s'",
        ERR0404 => "Config file `%s' is not found.",
        ERR0405 => "`l7directord.cf' is not found at default search paths.",
        ERR0406 => "`l7vsadm' file is not found at default search paths.",
        ERR0407 => "Cannot open config file `%s'.",
        ERR0408 => "Cannot close config file `%s'.",
        ERR0409 => "Cannot open pid file (%s): %s",
        ERR0410 => "Cannot get mtime of configuration file `%s'",
        ERR0411 => "No delete file specified.",
        ERR0412 => "Invalid pid specified. (pid: %s)",
        # undefined
        ERR0501 => "Some method arguments are undefined.",
        ERR0502 => "VirtualService ID is undefined.",
        ERR0503 => "HealthCheck ID is undefined.",
        ERR0504 => "negotiate function is undefined. So use check_connect function.",
        ERR0505 => "custom check script is undefined. So use check_off function.",
        # health check process
        ERR0601 => "Service up detected. (Real server `%s')",
        ERR0602 => "Service down detected. (Real server `%s')",
        ERR0603 => "Detected down monitor process (pid: %s). Prepare to re-start health check process. (id: `%s')",
        ERR0604 => "Failed to fork() on sub process creation. (id: `%s')",
        # daemon
        ERR0701 => "Cannot fork for become daemon (errno: `%s') and exit.",
        ERR0702 => "Cannot setsid for become daemon and exit.",
        ERR0703 => "Cannot chdir for become daemon and exit.",
        ERR0704 => "Cannot open /dev/null for become daemon and exit.",
        ERR0705 => "Cannot open /dev/console for become daemon and exit.",

        # signal
        WRN0001 => "l7directord `%s' received signal: %s. Terminate process.",
        WRN0002 => "l7directord `%s' received signal: %s. Reload configuration.",
        WRN0003 => "Signal TERM send error(pid: %d)",
        WRN0004 => "Signal HUP send error(pid: %d)",
        # config
        WRN0101 => "Configuration file `%s' has changed on disk.",
        WRN0102 => "Reread new configuration.",
        WRN0103 => "Ignore new configuration.",
        # service check OK
        WRN0203 => "Service check OK. HTTP response is valid. HTTP response status line is `%s' (real - `%s:%s')",
        WRN0204 => "Service check OK. Successfully connect SMTP server. (real - `%s:%s')",
        WRN0205 => "Service check OK. Successfully connect POP3 server. (real - `%s:%s')",
        WRN0206 => "Service check OK. Successfully connect IMAP server. (real - `%s:%s')",
        WRN0207 => "Service check OK. Successfully bind LDAP server. (real - `%s:%s')",
        WRN0208 => "Service check OK. NNTP response is valid. `%s' (real - `%s:%s')",
        WRN0209 => "Service check OK. Database response is valid. (real - `%s:%s')",
        WRN0210 => "Service check OK. Successfully connect socket to server. (real - `%s:%s')",
        WRN0211 => "Service check OK. SIP response is valid. `%s' (real - `%s:%s')",
        WRN0212 => "Service check OK. Successfully login FTP server. (real - `%s')",
        WRN0213 => "Service check OK. Successfully lookup DNS. (real - `%s:%s')",
        WRN0214 => "Service check OK. Successfully receive ping response. (real - `%s')",
        WRN0215 => "Custom check result OK. (real - `%s')",
        # perl warn
        WRN0301 => "Perl warning: `%s'",
        # service check NG
        WRN1001 => "Retry service check `%s' %d more time(s).",
        # - http
        WRN1101 => "Service check NG. Check URL `%s' is not valid. (real - `%s:%s')",
        WRN1102 => "Service check NG. HTTP response is not ok. Response status line is `%s' (real - `%s:%s')",
        WRN1103 => "Service check NG. Check string `%s' is not found in HTTP response. (real - `%s:%s')",
        # - smtp
        WRN1201 => "Service check NG. Cannot connect SMTP server. (real - `%s:%s')",
        # - pop3
        WRN1301 => "Service check NG. Cannot connect POP3 server. (real - `%s:%s')",
        WRN1302 => "Service check NG. Cannot login POP3 server. (real - `%s:%s')",
        # - imap
        WRN1401 => "Service check NG. Cannot connect IMAP server. (real - `%s:%s')",
        WRN1402 => "Service check NG. Cannot login IMAP server. (real - `%s:%s')",
        WRN1403 => "Service check NG. Connection timeout from IMAP server in %d seconds. (real - `%s:%s')",
        # - ldap
        WRN1501 => "Service check NG. Cannot connect LDAP server. (real - `%s:%s')",
        WRN1502 => "Service check NG. Connection timeout from LDAP server in %d seconds. (real - `%s:%s')",
        WRN1503 => "Service check NG. LDAP bind error. (real - `%s:%s')",
        WRN1504 => "Service check NG. Exists %d results (not one) on search Base DN. (real - `%s:%s')",
        WRN1505 => "Service check NG. Check string `%s' is not found in Base DN search result. (real - `%s:%s')",
        # - nntp
        WRN1601 => "Service check NG. Cannot connect NNTP server. (real - `%s:%s')",
        WRN1602 => "Service check NG. Connection timeout from NNTP server in %d seconds. (real - `%s:%s')",
        WRN1603 => "Service check NG. NNTP response is not ok. `%s' (real - `%s:%s')",
        # - sql
        WRN1701 => "Service check NG. SQL check must set `database', `login', `passwd' by configuration. (real - `%s:%s')",
        WRN1702 => "Service check NG. Cannot connect database or cannot login database. (real - `%s:%s')",
        WRN1703 => "Service check NG. Query result has no row. (real - `%s:%s')",
        WRN1704 => "Service check NG. Expected %d rows of query results, but got %d rows. (real - `%s:%s')",
        WRN1705 => "Service check NG. Connection timeout from database in %d seconds. (real - `%s:%s')",
        # - sip
        WRN1801 => "Service check NG. SIP check must set `login' by configuration. (real - `%s:%s')",
        WRN1802 => "Service check NG. Cannot connect SIP server. (real - `%s:%s')",
        WRN1803 => "Service check NG. SIP response is not ok. `%s' (real - `%s:%s')",
        WRN1804 => "Service check NG. Connection timeout from SIP server in %d seconds. (real - `%s:%s')",
        # - ftp
        WRN1901 => "Service check NG. FTP check must set `login', `passwd' by configuration. (real - `%s')",
        WRN1902 => "Service check NG. Cannot connect FTP server. (real - `%s')",
        WRN1903 => "Service check NG. Cannot login FTP server. (real - `%s')",
        WRN1904 => "Service check NG. Cannot chdir to / of FTP server. (real - `%s')",
        WRN1905 => "Service check NG. Cannot get file `%s' (real - `%s')",
        WRN1906 => "Service check NG. Check string `%s' is not found in file `%s' (real - `%s')",
        WRN1907 => "Service check NG. Exception occur during FTP check `%s' (real - `%s')",
        WRN1908 => "Service check NG. Connection timeout from FTP server in %d seconds. (real - `%s')",
        # - dns
        WRN2001 => "Service check NG. DNS check must set `request', `receive' by configuration. (real - `%s:%s')",
        WRN2002 => "Service check NG. Connection timeout from DNS server in %d seconds. (real - `%s:%s')",
        WRN2003 => "Service check NG. Net::DNS exception occur `%s' (real - `%s:%s')",
        WRN2004 => "Service check NG. DNS search `%s' not respond. (real - `%s:%s')",
        WRN2005 => "Service check NG. Check string `%s' is not found in search result. (real - `%s:%s')",
        # - ping
        WRN3101 => "Service check NG. Ping timeout in %d seconds. (real - `%s')",
        # - connect
        WRN3201 => "Service check NG. Cannot connect socket to server. (errno: `%s') (real - `%s:%s')",
        # - custom
        WRN3301 => "Custom check NG. Check timeout in %d seconds. (real - `%s')",
        WRN3302 => "Custom check NG. `%s' returns %d",

        # start stop
        INF0001 => "Starting program with command: `%s'",
        INF0002 => "Starting l7directord v%s with pid: %d (configuration: `%s')",
        INF0003 => "Starting l7directord v%s as daemon. (configuration: `%s')",
        INF0004 => "Exit by initialize error.",
        INF0005 => "Exit parent process for become daemon",
        INF0006 => "Exiting with exit status %d: %s",
        INF0007 => "Detected halt flag. Exit this monitor process with status: 0",
        INF0008 => "Reached end of `main'",
        # stderr
        INF0101 => "l7directord for `%s' is running with pid: %d",
        INF0102 => "l7directord stale pid file %s for %s",
        INF0103 => "Other l7directord process is running. (pid: %d)",
        INF0104 => "l7directord process is not running.",
        # l7vsd
        INF0201 => "Add virtual service to l7vsd: `%s %s'",
        INF0202 => "Edit virtual service on l7vsd: `%s %s'",
        INF0203 => "Delete virtual service from l7vsd: `%s %s'",
        INF0204 => "Add server to l7vsd: `%s' ( x `%s %s') (weight set to %d)",
        INF0205 => "Edit server on l7vsd: `%s' ( x `%s %s') (weight set to %d)",
        INF0206 => "Delete server from l7vsd: `%s' ( x `%s %s')",
        # server change
        INF0301 => "Added real server. (`%s')",
        INF0302 => "Added fallback server. (`%s')",
        INF0303 => "Changed real server to quiescent state. (`%s')",
        INF0304 => "Changed fallback server to quiescent state. (`%s')",
        INF0305 => "Deleted real server. (`%s')",
        INF0306 => "Deleted fallback server. (`%s')",
        # health check
        INF0401 => "Prepare to start health check process. (id: `%s')",
        INF0402 => "Create health check process with pid: %d. (id `%s')",
        # run
        INF0501 => "Real server down shell execute: `%s %s'",
        INF0502 => "Real server recovery shell execute: `%s %s'",
        INF0503 => "Config callback shell execute: `%s %s'",
        INF0504 => "Running system: `%s'",
        INF0505 => "Running exec: `%s'",
        INF0506 => "Running command: `%s'",
        };

    my $message
        = exists $message_list->{$code} ? sprintf $message_list->{$code}, @message_args
        : "Unknown message. (code:[$code] args:[" . join(q{, }, @message_args) . '])';

    return $message;
}

# _message
# Create message by _message_only and add code header.
sub _message {
    my ($code, @message_args) = @_;
    my $message = _message_only($code, @message_args);
    $message = "[$code] $message";
    return $message;
}

1;

__END__

=head1 NAME

l7directord - UltraMonkey-L7 Director Daemon

Daemon to monitor remote services and control UltraMonkey-L7


=head1 SYNOPSIS

B<l7directord> [B<-d>] [I<configuration>] {B<start>|B<stop>|B<restart>|B<try-restart>|B<reload>|B<status>|B<configtest>}

B<l7directord> B<-t> [I<configuration>]

B<l7directord> B<-h|--help>

B<l7directord> B<-v|--version>

=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 UltraMonkey-L7.
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<-v>

Version. Print version of l7directord.

=item B<-t>

Run syntax tests for configuration files only. The program immediately exits after these syntax parsing tests
with either a return code of 0 (Syntax OK) or return code not equal to 0 (Syntax Error).

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

Show status of the running daemon for the specified configuration.

=item B<configtest>

This is the same as B<-t>.

=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 5 seconds.
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.
If defined in virtual server section then the global value is overridden.

=item B<retryinterval = >I<n>

Defines the number of second between server checks when server status is NG.
Default is 10 seconds. If defined in virtual server section then the global
value is overridden.

=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 and retryinterval is 1 second,
then a total of 8 seconds (2 + 1 + 2 + 1 + 2) 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<configinterval = >I<n>

Defines the number of second between configuration checks.
Default is 5 seconds.

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

Defines if <l7directord> should continuously check the configuration file
for modification each B<configinterval> seconds. 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/l7vs/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 UltraMonkey-L7,
but set weight to zero.
If B<no>, then the real or fallback servers will be removed
from the UltraMonkey-L7. 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, --pattern-match '*.html*').
B<module-args> is optional only when set B<sessionless>, B<ip> 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<qosup => I<n>[B<K>|B<M>|B<G>]

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

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

Defines the bandwidth quota size in bps for down stream. If the number of the
bandwidth is over the qosdown limit, a packet to the client will be delayed
until the number of bandwidth become below the qosdown 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<custom>|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. Custom means that
custom command will be used to test the availability of real servers.
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 UltraMonkey-L7 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).

=item B<customcheck = ">I<custom check command>B<">

If this directive is defined and set B<checktype> to custom, B<l7directord>
exec custom command for real servers health checking. Only if custom command
returns 0, real servers will change to up. Otherwise real servers will change
to down. Custom check command has some macro string. See below.

=over

=item B<_IP_>

Change to real server IP address.

=item B<_PORT_>

Change to real server port number.

=back

=back


=head1 FILES

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

B</var/log/l7vs/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