l7directord/l7directord

   1 #!/usr/bin/perl
   2 ######################################################################
   3 # l7directord
   4 # Linux Director Daemon - run "perldoc l7directord" for details
   5 #
   6 # Copyright (C) 2005-2010  NTT COMWARE Corporation.
   7 #
   8 # License:   GNU General Public License (GPL)
   9 #
  10 # This program is developed on similar lines of ldirectord. It handles
  11 # l7vsadm and monitoring of real servers.
  12 #
  13 # The version of ldirectord used as a reference for this l7directord is
  14 # ldirectord,v 1.77.2.32 2005/09/21 04:00:41
  15 #
  16 # Note : * The existing code of ldirectord that is not required for
  17 #          l7directord is also maintained in the program but is
  18 #          commented out.
  19 #
  20 # This program is free software; you can redistribute it and/or
  21 # modify it under the terms of the GNU General Public License as
  22 # published by the Free Software Foundation; either version 2 of the
  23 # License, or (at your option) any later version.
  24 #
  25 # This program is distributed in the hope that it will be useful, but
  26 # WITHOUT ANY WARRANTY; without even the implied warranty of
  27 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  28 # General Public License for more details.
  29 #
  30 # You should have received a copy of the GNU General Public License
  31 # along with this program; if not, write to the Free Software
  32 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  33 # 02110-1301 USA
  34 ######################################################################
  35
  36 # Revision History :
  37 #   0.5.0-0: Added code related to Sorry server and Max connection
  38 #            - 2006/11/03 NTT COMWARE
  39 #   1.0.0-0: Added code related to weight of real server and QoS
  40 #            - 2007/10/12 NTT COMWARE
  41 #   1.0.1-0: Added the code below.
  42 #            configuration of realdowncallback, realrecovercallback,
  43 #            and sessionless module.
  44 #            - 2007/12/28 NTT COMWARE
  45 #   1.0.2-0: Added the code below.
  46 #            cookie insert with X-Forwarded-For module(cinsert_xf)
  47 #            - 2008/1/14 Shinya TAKEBAYASHI
  48 #   2.0.0-0: Added code related to sslid module.
  49 #            cinsert_xf module is marged into cinsert module.
  50 #            Added code related to syntax test of configuration.
  51 #            Expanded checkcount setting to all service check.
  52 #            - 2008/03/25 Norihisa NAKAI
  53 #   2.1.0-0: Changed helthcheck logic to multi-process.
  54 #            - 2008/12/17 NTT COMWARE
  55 #   2.1.1-0: Fix 'Range iterator outside integer range' in parse_real.
  56 #            - 2009/01/06 NTT COMWARE
  57 #   2.1.2-0: Added code related to some module. See below.
  58 #            (cpassive, crewrite, pfilter, url, ip)
  59 #            Add custom healthcheck.
  60 #            (checktype=custom, customcheck=exec_command)
  61 #            - 2009/02/14 NTT COMWARE
  62 #   3.0.0-1: Add code related to l7vsd v3.0.0. See below.
  63 #             - Add accesslog option.
  64 #             - Add tproxy option.
  65 #   3.0.4-1: Change module check rule. Allow module name
  66 #            [a-z]+.
  67 #   3.1.0-1: Add code related to l7vsd v3.1.0. See below.
  68 #             - Add session_thread_pool_size option.
  69 #
  70
  71 use 5.006;
  72 use strict;
  73 use warnings;
  74 use Getopt::Long qw(:config posix_default);
  75 use Sys::Hostname;
  76 use POSIX qw(:sys_wait_h :signal_h);
  77 use Sys::Syslog qw(:DEFAULT setlogsock);
  78 use English;
  79 use Fatal qw(open close);
  80 use Cwd qw(abs_path);
  81 use Data::Dumper;
  82 use Time::HiRes qw(sleep);
  83 use IO::Handle;
  84 use Socket;
  85 use Socket6;
  86
  87 # current version
  88 our $VERSION     = '3.1.0-1';
  89 our $COPYRIGHT   = 'Copyright (C) 2012 NTT COMWARE CORPORATION';
  90
  91 # default global config values
  92 our %GLOBAL = (
  93     logfile          => '/var/log/l7vs/l7directord.log',
  94     autoreload       => 0,
  95     checkcount       => 1,
  96     checkinterval    => 10,
  97     retryinterval    => 10,
  98     configinterval   => 5,
  99     checktimeout     => 5,
 100     negotiatetimeout => 5,
 101     supervised       => 0,
 102     quiescent        => 1,
 103     virtual          => undef,
 104     execute          => undef,
 105     fallback         => undef,
 106     callback         => undef,
 107     );
 108
 109 # default virtual config values
 110 our %VIRTUAL = (
 111     real                => undef,
 112     module              => { name => 'sessionless', key => q{} },
 113     scheduler           => 'rr',
 114     protocol            => 'tcp',
 115     checktype           => 'negotiate',
 116     service             => undef,
 117     checkport           => undef,
 118     maxconn             => 0,
 119     qosup               => 0,
 120     qosdown             => 0,
 121     sorryserver         => { ip => '0.0.0.0', port => 0, forward => 'none' },
 122     request             => undef,
 123     receive             => undef,
 124     httpmethod          => 'GET',
 125     virtualhost         => undef,
 126     login               => q{},
 127     passwd              => q{},
 128     database            => q{},
 129     realdowncallback    => undef,
 130     realrecovercallback => undef,
 131     customcheck         => undef,
 132     sslconfigfile       => undef,
 133     accesslog           => undef,
 134     accesslogfile       => undef,
 135     socketoption        => undef,
 136     accesslog_rotate_type                  => undef,
 137     accesslog_rotate_max_backup_index      => undef,
 138     accesslog_rotate_max_filesize          => undef,
 139     accesslog_rotate_rotation_timing       => undef,
 140     accesslog_rotate_rotation_timing_value => undef,
 141     session_thread_pool_size               => undef,
 142     other_virtual_key                      => undef,
 143     # can override
 144     checkcount          => undef,
 145     checkinterval       => undef,
 146     retryinterval       => undef,
 147     checktimeout        => undef,
 148     negotiatetimeout    => undef,
 149     quiescent           => undef,
 150     fallback            => undef,
 151     );
 152
 153 # default real config values
 154 our %REAL = (
 155     weight              => 1,
 156     forward             => 'masq',
 157     # can override
 158     request             => undef,
 159     receive             => undef,
 160     );
 161
 162 # current config data
 163 our %CONFIG = %GLOBAL;
 164
 165 # config file data
 166 our %CONFIG_FILE = (
 167     path            => undef,
 168     filename        => undef,
 169     checksum        => undef,
 170     stattime        => undef,
 171     );
 172
 173 # process environment
 174 our %PROC_ENV = (
 175     l7directord => $0,
 176     l7vsadm     => undef,
 177     pid_prefix  => '/var/run/l7directord',
 178     hostname    => undef,
 179     );
 180
 181 # process status
 182 our %PROC_STAT = (
 183     pid             => $PID,
 184     initialized     => 0,
 185     log_opened      => 0,
 186     health_checked  => 0,
 187     halt            => undef,
 188     reload          => undef,
 189     );
 190
 191 # debug level
 192 our $DEBUG_LEVEL = 0;
 193
 194 # health check process data
 195 our %HEALTH_CHECK  = ();
 196
 197 # real server health flag
 198 our $SERVICE_UP   = 0;
 199 our $SERVICE_DOWN = 1;
 200
 201 # section virtual sub config prefix
 202 our $SECTION_VIRTUAL_PREFIX = "    ";
 203
 204 main();
 205
 206 # main
 207 # Main method of this program.
 208 # parse command line and run each command method.
 209 sub main {
 210     my $cmd_func = {
 211         start         => \&cmd_start,
 212         stop          => \&cmd_stop,
 213         restart       => \&cmd_restart,
 214         'try-restart' => \&cmd_try_restart,
 215         reload        => \&cmd_reload,
 216         status        => \&cmd_status,
 217         configtest    => \&cmd_configtest,
 218         version       => \&cmd_version,
 219         help          => \&cmd_help,
 220         usage         => \&cmd_usage,
 221         };
 222
 223     # change program name for removing `perl' string from `ps' command result.
 224     my $ps_name = @ARGV ? $PROGRAM_NAME . " @ARGV"
 225                         : $PROGRAM_NAME;
 226     $PROGRAM_NAME = $ps_name;
 227
 228     my $cmd_mode = parse_cmd();
 229     if ( !defined $cmd_mode || !exists $cmd_func->{$cmd_mode} ) {
 230         $cmd_mode = 'usage';
 231     }
 232     if ($cmd_mode ne 'help' && $cmd_mode ne 'version' && $cmd_mode ne 'usage') {
 233         initial_setting();
 234     }
 235
 236     # execute command.
 237     my $cmd_result = &{ $cmd_func->{$cmd_mode} }();
 238
 239     ld_exit( $cmd_result, _message_only('INF0008') );
 240 }
 241
 242 # parse_cmd
 243 # Parse command line (ARGV)
 244 sub parse_cmd {
 245     # configtest or help command
 246     my $cmd_mode = parse_option();
 247
 248     # other command
 249     if (!defined $cmd_mode && @ARGV) {
 250         $cmd_mode = pop @ARGV;
 251     }
 252     return $cmd_mode;
 253 }
 254
 255 # parse_option
 256 # Parse option strings by Getopt::Long
 257 sub parse_option {
 258     my $cmd_mode = undef;
 259
 260     # default option value
 261     my $debug   = undef;
 262     my $help    = undef;
 263     my $test    = undef;
 264     my $version = undef;
 265
 266     # parse command line options
 267     my $result = GetOptions(
 268         'd:3'       => \$debug,   # debug mode, arg: debug level (default 3)
 269         'h|help'    => \$help,    # show help message
 270         't'         => \$test,    # config syntax test
 271         'v|version' => \$version, # show version
 272         );
 273
 274     if ($result) {
 275         # set debug level
 276         if (defined $debug) {
 277             $DEBUG_LEVEL = $debug;
 278         }
 279
 280         # set command mode
 281         if (defined $help) {
 282             $cmd_mode = 'help';
 283         }
 284         elsif (defined $version) {
 285             $cmd_mode = 'version';
 286         }
 287         elsif (defined $test) {
 288             $cmd_mode = 'configtest';
 289         }
 290     }
 291     else {
 292         $cmd_mode = 'usage';
 293     }
 294
 295     return $cmd_mode;
 296 }
 297
 298 # initial_setting
 299 # Initialize file path settings.
 300 sub initial_setting {
 301     # search config and l7vsadm
 302     $PROC_ENV{l7vsadm} = search_l7vsadm_file();
 303     $CONFIG_FILE{path} = search_config_file();
 304
 305     # get config file name exclude `.cf' or `.conf'
 306     ( $CONFIG_FILE{filename} )
 307         = $CONFIG_FILE{path} =~ m{([^/]+?)(?:\.cf|\.conf)?$};
 308
 309     # get hostname
 310     $PROC_ENV{hostname}
 311         = defined $ENV{HOSTNAME} ? $ENV{HOSTNAME}
 312         :                          ( POSIX::uname() )[1]
 313         ;
 314 }
 315
 316 # search_config_file
 317 # Search l7directord.cf file from search path.
 318 sub search_config_file {
 319     my $config_file = undef;
 320     my @search_path = qw(
 321         /etc/ha.d/conf/l7directord.cf
 322         /etc/ha.d/l7directord.cf
 323         ./l7directord.cf
 324         );
 325
 326     if (@ARGV) {
 327         $config_file = $ARGV[0];
 328         if (!-f $ARGV[0]) {
 329             init_error( _message_only('ERR0404', $config_file) );
 330         }
 331     }
 332     else {
 333         for my $file (@search_path) {
 334             if (-f $file) {
 335                 $config_file = $file;
 336                 last;
 337             }
 338         }
 339         if (!defined $config_file) {
 340             init_error( _message_only('ERR0405', $config_file) );
 341         }
 342     }
 343
 344     return abs_path($config_file);
 345 }
 346
 347 # search_l7vsadm_file
 348 # Search l7vsadm file from search path.
 349 sub search_l7vsadm_file {
 350     my $l7vsadm_file = undef;
 351     my @search_path = qw(
 352         /usr/sbin/l7vsadm
 353         /sbin/l7vsadm
 354         ./l7vsadm
 355         );
 356
 357     for my $file (@search_path) {
 358         if (-x $file) {
 359             $l7vsadm_file = $file;
 360             last;
 361         }
 362     }
 363     if (!defined $l7vsadm_file) {
 364         init_error( _message_only('ERR0406', $l7vsadm_file) );
 365     }
 366
 367     return abs_path($l7vsadm_file);
 368 }
 369
 370 # cmd_start
 371 # Start process
 372 # Called if command argument is start
 373 # return: 0 if success
 374 #         1 if old process id is found.
 375 sub cmd_start {
 376     set_ld_handler();
 377     read_config();
 378
 379     ld_log( _message('INF0001', $PROGRAM_NAME) );
 380
 381     ld_setup();
 382
 383     my $oldpid = read_pid();
 384
 385     # already other process is running
 386     if ($oldpid) {
 387         print {*STDERR} _message_only('INF0103', $oldpid) . "\n";
 388         return 1;
 389     }
 390
 391     # supervised or debug mode (not daemon)
 392     if ($CONFIG{supervised} || $DEBUG_LEVEL > 0) {
 393         ld_log( _message( 'INF0002', $VERSION, $PID, $CONFIG_FILE{path} ) );
 394     }
 395     # otherwise (daemon)
 396     else {
 397         ld_daemon();
 398         ld_log( _message( 'INF0003', $VERSION, $CONFIG_FILE{path} ) );
 399     }
 400
 401     write_pid( $PROC_STAT{pid} );
 402     ld_cmd_children('start');
 403     ld_main();
 404     ld_cmd_children('stop');
 405     remove_pid();
 406
 407     return 0;
 408 }
 409
 410 # cmd_stop
 411 # Send stop signal (TERM)
 412 # Called if command argument is stop
 413 # return: 0 if success
 414 #         2 if old process id is not found.
 415 #         3 if signal failed.
 416 sub cmd_stop {
 417     my ($oldpid, $stalepid) = read_pid();
 418
 419     # process is not running
 420     if (!$oldpid) {
 421         if ($stalepid) {
 422             my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
 423             print {*STDERR} _message_only('INF0102', $pid_file, $CONFIG_FILE{path}) . "\n";
 424         }
 425         print {*STDERR} _message_only('INF0104') . "\n";
 426         return 2;
 427     }
 428
 429     # signal TERM
 430     my $signaled = kill 15, $oldpid;
 431     if ($signaled != 1) {
 432         print {*STDERR} _message('WRN0003', $oldpid);
 433         return 3;
 434     }
 435
 436     # wait and see
 437     while (1) {
 438         read_pid() or last;
 439         sleep 1;
 440     }
 441     return 0;
 442 }
 443
 444 # cmd_restart
 445 # Restart process
 446 # Called if command argument is restart
 447 # return: see cmd_start return
 448 sub cmd_restart {
 449     # stop and ignore result
 450     cmd_stop();
 451
 452     # start
 453     my $status = cmd_start();
 454
 455     return $status;
 456 }
 457
 458 # cmd_try_restart
 459 # Trying restart process
 460 # Called if command argument is try-restart
 461 # return: see cmd_start, cmd_stop return
 462 sub cmd_try_restart {
 463     # stop
 464     my $stop_result = cmd_stop();
 465
 466     # start only if stop succeed
 467     if ($stop_result != 0) {
 468         return $stop_result;
 469     }
 470
 471     # start
 472     my $status = cmd_start();
 473
 474     return $status;
 475 }
 476
 477 # cmd_reload
 478 # Send reload signal (HUP)
 479 # Called if command argument is reload
 480 # return: 0 if success
 481 #         2 if old process id is not found.
 482 #         3 if signal failed.
 483 sub cmd_reload {
 484     read_config();
 485     my ($oldpid, $stalepid) = read_pid();
 486     if (!$oldpid) {
 487         if ($stalepid) {
 488             my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
 489             print {*STDERR} _message_only( 'INF0102', $pid_file, $CONFIG_FILE{path} ) . "\n";
 490         }
 491         print {*STDERR} _message_only('INF0104') . "\n";
 492         return 2;
 493     }
 494
 495     # signal HUP
 496     my $signaled = kill 1, $oldpid;
 497     if ($signaled != 1) {
 498         print {*STDERR} _message('WRN0004', $oldpid);
 499         return 3;
 500     }
 501     return 0;
 502 }
 503
 504 # cmd_status
 505 # Show process id of running
 506 # Called if command argument is status
 507 # return: 0 if success
 508 #         2 if old process id is not found.
 509 sub cmd_status {
 510     my ($oldpid, $stalepid) = read_pid();
 511     if (!$oldpid) {
 512         if ($stalepid) {
 513             my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
 514             print {*STDERR} _message_only('INF0102', $pid_file, $CONFIG_FILE{path}) . "\n";
 515         }
 516         print {*STDERR} _message_only('INF0104') . "\n";
 517         ld_cmd_children('status');
 518
 519         return 2;
 520     }
 521
 522     print {*STDERR} _message_only('INF0101', $CONFIG_FILE{path}, $oldpid) . "\n";
 523
 524     read_config();
 525     ld_cmd_children('status');
 526
 527     return 0;
 528 }
 529
 530 # cmd_version
 531 # Configuration syntax check
 532 # Called if command argument is configtest
 533 # return: 0 if syntax ok
 534 #         otherwise, exit by read_config
 535 sub cmd_configtest {
 536     read_config();
 537     print {*STDOUT} "Syntax OK\n";
 538     return 0;
 539 }
 540
 541 # cmd_version
 542 # Show program version.
 543 # Called if command argument is version
 544 # return: 0
 545 sub cmd_version {
 546     print {*STDOUT} "l7directord, version $VERSION\n$COPYRIGHT\n";
 547     return 0;
 548 }
 549
 550 # cmd_help
 551 # Show command manual.
 552 # Called if command argument is help
 553 # return: 0
 554 sub cmd_help {
 555     system_wrapper( '/usr/bin/perldoc ' . $PROC_ENV{l7directord} );
 556     return 0;
 557 }
 558
 559 # cmd_usage
 560 # Show command usage.
 561 # Called if command argument is unknown or not specified.
 562 # return: 0
 563 sub cmd_usage {
 564     print {*STDERR}
 565         "Usage: l7directord {start|stop|restart|try-restart|reload|status|configtest}\n"
 566       . "Try `l7directord --help' for more information.\n";
 567     return 0;
 568 }
 569
 570 # set_ld_handler
 571 # Set signal handler function.
 572 sub set_ld_handler {
 573     $SIG{ INT  } = \&ld_handler_term;
 574     $SIG{ QUIT } = \&ld_handler_term;
 575     $SIG{ ILL  } = \&ld_handler_term;
 576     $SIG{ ABRT } = \&ld_handler_term;
 577     $SIG{ FPE  } = \&ld_handler_term;
 578     $SIG{ SEGV } = \&ld_handler_term;
 579     $SIG{ TERM } = \&ld_handler_term;
 580     $SIG{ BUS  } = \&ld_handler_term;
 581     $SIG{ SYS  } = \&ld_handler_term;
 582     $SIG{ XCPU } = \&ld_handler_term;
 583     $SIG{ XFSZ } = \&ld_handler_term;
 584     # HUP is actually used
 585     $SIG{ HUP  } = \&ld_handler_hup;
 586     # This used to call a signal handler, that logged a message
 587     # However, this typically goes to syslog and if syslog
 588     # is playing up a loop will occur.
 589     $SIG{ PIPE } = 'IGNORE';
 590     # handle perl warn signal
 591     $SIG{__WARN__} = \&ld_handler_perl_warn;
 592 }
 593
 594 # ld_handler_perl_warn
 595 # Handle Perl warnings for logging file.
 596 sub ld_handler_perl_warn {
 597     my $warning = join q{, }, @_;
 598     $warning =~ s/[\r\n]//g;
 599     ld_log( _message('WRN0301', $warning) );
 600 }
 601
 602 # read_pid
 603 # Read pid file and check if pid (l7directord) is still running
 604 sub read_pid {
 605     my $old_pid  = undef;
 606     my $file_pid = undef;
 607     my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
 608     eval {
 609         open my $pid_handle, '<', $pid_file;
 610         $file_pid = <$pid_handle>;
 611         close $pid_handle;
 612         chomp $file_pid;
 613
 614         # Check to make sure this isn't a stale pid file
 615         my $proc_file = "/proc/$file_pid/cmdline";
 616         open my $proc_handle, '<', $proc_file;
 617         my $line = <$proc_handle>;
 618         if ($line =~ /l7directord/) {
 619             $old_pid = $file_pid;
 620         }
 621         close $proc_handle;
 622     };
 623
 624     return wantarray ? ($old_pid, $file_pid) : $old_pid;
 625 }
 626
 627 # write_pid
 628 # Write pid number to pid file.
 629 sub write_pid {
 630     my $pid = shift;
 631
 632     my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
 633     if (!defined $pid || $pid !~ /^\d+$/ || $pid < 1) {
 634         $pid = defined $pid ? $pid : 'undef';
 635         init_error( _message_only('ERR0412', $pid) );
 636     }
 637     eval {
 638         open my $pid_handle, '>', $pid_file;
 639         print {$pid_handle} $pid . "\n";
 640         close $pid_handle;
 641     };
 642     if ($EVAL_ERROR) {
 643         init_error( _message_only('ERR0409', $pid_file, $EVAL_ERROR) );
 644     }
 645 }
 646
 647 # remove_pid
 648 # Remove pid file.
 649 sub remove_pid {
 650     my $pid_file = $PROC_ENV{pid_prefix} . q{.} . $CONFIG_FILE{filename} . '.pid';
 651     ld_rm_file($pid_file);
 652 }
 653
 654 # init_error
 655 # Handle error during initialization and exit.
 656 sub init_error {
 657     my $msg = shift;
 658     if (defined $msg) {
 659         if ($DEBUG_LEVEL == 0) {
 660             print {*STDERR} $msg . "\n";
 661         }
 662         ld_log( _message('ERR0001', $msg) );
 663     }
 664     ld_exit( 4, _message_only('INF0004') );
 665 }
 666
 667 # ld_handler_term
 668 # If we get a sinal then put a halt flag up
 669 sub ld_handler_term {
 670     my $signal = shift;
 671     $PROC_STAT{halt} = defined $signal ? $signal : 'undef';
 672 }
 673
 674 # ld_handler_hup
 675 # If we get a sinal then put a reload flag up
 676 sub ld_handler_hup {
 677     my $signal = shift;
 678     $PROC_STAT{reload} = defined $signal ? $signal : 'undef';
 679 }
 680
 681 # reread_config
 682 # Re-read config, and then re-setup l7vsd and child process.
 683 sub reread_config {
 684     my $old_virtual = defined $CONFIG{virtual} ? [ @{ $CONFIG{virtual} } ]
 685                     :                            []
 686                     ;
 687     my %old_sub_config = defined $CONFIG{execute} ? %{ $CONFIG{execute} }
 688                        :                            ()
 689                        ;
 690
 691     %CONFIG = %GLOBAL;
 692     $CONFIG{old_virtual} = $old_virtual;
 693
 694     # analyze config and catch format error
 695     eval {
 696         read_config();
 697         ld_setup();
 698         ld_start();
 699     };
 700     if ($EVAL_ERROR) {
 701         my $exception = $EVAL_ERROR;
 702         chomp $exception;
 703         ld_log( _message('ERR0122', $exception) );
 704         $CONFIG{virtual} = [ @{ $CONFIG{old_virtual} } ];
 705         $CONFIG{execute} = \%old_sub_config;
 706     }
 707
 708     my %new_sub_config = defined $CONFIG{execute} ? %{ $CONFIG{execute} }
 709                        :                            ()
 710                        ;
 711     for my $sub_config ( keys %old_sub_config ) {
 712         if ( exists $new_sub_config{$sub_config} ) {
 713             if ( system_wrapper($PROC_ENV{l7directord} . " $sub_config reload") ) {
 714                  system_wrapper($PROC_ENV{l7directord} . " $sub_config start");
 715             }
 716             delete $new_sub_config{$sub_config};
 717             delete $old_sub_config{$sub_config};
 718         }
 719     }
 720     ld_cmd_children('stop',  \%old_sub_config);
 721     ld_cmd_children('start', \%new_sub_config);
 722 }
 723
 724 # read_config
 725 # Read configuration and parse settings.
 726 sub read_config {
 727     my $line = 0;
 728     my $current_global_name = q{};
 729     my $config_handle;
 730
 731     eval {
 732         open $config_handle, '<', $CONFIG_FILE{path};
 733     };
 734     if ($EVAL_ERROR) {
 735         config_error( 0, 'ERR0407', $CONFIG_FILE{path} );
 736     }
 737
 738     while (my $config_line = <$config_handle>) {
 739         $line++;
 740         chomp $config_line;
 741         $config_line =~ s/#.*//mg; # remove comment (FIXME optimize regex for "foo='#'")
 742         $config_line =~ s/^\t/$SECTION_VIRTUAL_PREFIX/mg; # convert tab to prefix
 743
 744         next if ($config_line =~ /^(?:$SECTION_VIRTUAL_PREFIX)?\s*$/);
 745
 746         # section global
 747         if ($config_line !~ /^$SECTION_VIRTUAL_PREFIX/) {
 748             my ($name, $value) = validate_config($line, $config_line);
 749             $current_global_name = $name;
 750             if ($name eq 'virtual') {
 751                 my %virtual = %VIRTUAL;
 752                 $virtual{server} = $value;
 753                 push @{ $CONFIG{virtual} }, \%virtual;
 754                 _ld_service_resolve(\%virtual, $value->{port});
 755             }
 756             elsif ($name eq 'execute') {
 757                 $CONFIG{execute}{$value} = 1;
 758             }
 759             else {
 760                 $CONFIG{$name} = $value;
 761             }
 762         }
 763         # section virtual
 764         else {
 765             if ($current_global_name ne 'virtual') {
 766                 config_error($line, 'ERR0119', $config_line);
 767             }
 768             my ($name, $value) = validate_config($line, $config_line);
 769             if ($name eq 'real' && defined $value) {
 770                 push @{ $CONFIG{virtual}[-1]{real} }, @$value;
 771             }
 772             elsif (defined $value) {
 773                 $CONFIG{virtual}[-1]{$name} = $value;
 774             }
 775         }
 776     }
 777
 778     eval {
 779         close $config_handle;
 780     };
 781     if ($EVAL_ERROR) {
 782         config_error( 0, 'ERR0408', $CONFIG_FILE{path} );
 783     }
 784
 785     ld_openlog( $CONFIG{logfile} ) if !$PROC_STAT{log_opened};
 786     check_require_module();
 787     undef $CONFIG_FILE{checksum};
 788     undef $CONFIG_FILE{stattime};
 789     check_cfgfile();
 790
 791     $PROC_STAT{initialized} = 1;
 792 }
 793
 794 # validate_config
 795 # Validation check of configuration.
 796 sub validate_config {
 797     my ($line, $config) = @_;
 798     my ($name, $value) = split /\s*=\s*/, $config, 2;
 799     if (defined $value) {
 800         $value =~ s/\s*$//;
 801         $value =~ s/^("|')(.*)\1$/$2/;
 802     }
 803
 804     # section global validate
 805     if ($name !~ /^$SECTION_VIRTUAL_PREFIX/) {
 806         if (!exists $GLOBAL{$name}) {
 807             config_error($line, 'ERR0120', $config);
 808         }
 809         if ($name eq 'virtual') {
 810             $value = ld_gethostservbyname($value, 'tcp');
 811             if (!defined $value) {
 812                 config_error($line, 'ERR0114', $config);
 813             }
 814         }
 815         elsif (    $name eq 'checktimeout'
 816                 || $name eq 'negotiatetimeout'
 817                 || $name eq 'checkinterval'
 818                 || $name eq 'retryinterval'
 819                 || $name eq 'configinterval'
 820                 || $name eq 'checkcount'      ) {
 821             if (!defined $value || $value !~ /^\d+$/ || $value == 0 ) {
 822                 config_error($line, 'ERR0101', $config);
 823             }
 824         }
 825         elsif (    $name eq 'autoreload'
 826                 || $name eq 'quiescent'  ) {
 827             $value = defined $value && $value =~ /^yes$/i ? 1
 828                    : defined $value && $value =~ /^no$/i  ? 0
 829                    :                                     undef
 830                    ;
 831             if (!defined $value) {
 832                 config_error($line, 'ERR0102', $config);
 833             }
 834         }
 835         elsif ($name eq 'fallback') {
 836             my $fallback = parse_fallback($line, $value, $config);
 837             $value = {tcp => $fallback};
 838         }
 839         elsif ($name eq 'callback') {
 840             if (!defined $value || !-f $value || !-x $value) {
 841                 config_error($line, 'ERR0117', $config);
 842             }
 843         }
 844         elsif ($name eq 'execute') {
 845             if (!defined $value || !-f $value) {
 846                 config_error($line, 'ERR0116', $config);
 847             }
 848         }
 849         elsif ($name eq 'logfile') {
 850             if (!defined $value || ld_openlog($value) ) {
 851                 config_error($line, 'ERR0118', $config);
 852             }
 853         }
 854         elsif ($name eq 'supervised') {
 855             $value = 1;
 856         }
 857     }
 858     # section virtual validate
 859     else {
 860         $name =~ s/^$SECTION_VIRTUAL_PREFIX\s*//g;
 861         if (!exists $VIRTUAL{$name}) {
 862             config_error($line, 'ERR0120', $config);
 863         }
 864         if ($name eq 'real') {
 865             $value = parse_real($line, $value, $config);
 866         }
 867         elsif (    $name eq 'request'
 868                 || $name eq 'receive'
 869                 || $name eq 'login'
 870                 || $name eq 'passwd'
 871                 || $name eq 'database'
 872                 || $name eq 'customcheck'
 873                 || $name eq 'virtualhost' ) {
 874             if (!defined $value || $value !~ /^.+$/) {
 875                 config_error($line, 'ERR0103', $config);
 876             }
 877         }
 878         elsif ($name eq 'checktype') {
 879             my $valid_type = qr{custom|connect|negotiate|ping|off|on|\d+};
 880             $value = lc $value;
 881             if (!defined $value || $value !~ /^(?:$valid_type)$/) {
 882                 config_error($line, 'ERR0104', $config);
 883             }
 884             if ($value =~ /^\d+$/ && $value == 0) {
 885                 config_error($line, 'ERR0104', $config);
 886             }
 887         }
 888         elsif (    $name eq 'checktimeout'
 889                 || $name eq 'negotiatetimeout'
 890                 || $name eq 'checkinterval'
 891                 || $name eq 'retryinterval'
 892                 || $name eq 'checkcount'
 893                 || $name eq 'maxconn'         ) {
 894             if (!defined $value || $value !~ /^\d+$/ || ($name ne 'maxconn' && $value == 0) ) {
 895                 config_error($line, 'ERR0101', $config);
 896             }
 897         }
 898         elsif ($name eq 'checkport') {
 899             if (!defined $value || $value !~ /^\d+$/ || $value == 0 || $value > 65535) {
 900                 config_error($line, 'ERR0108', $config);
 901             }
 902         }
 903         elsif ($name eq 'scheduler') {
 904             if ( $value =~ /[^a-z]/ ) {
 905                 config_error($line, 'ERR0105', $config);
 906             }
 907         }
 908         elsif ($name eq 'protocol') {
 909             $value = lc $value;
 910             if (!defined $value || $value !~ /^tcp$/) {
 911                 config_error($line, 'ERR0109', $config);
 912             }
 913         }
 914         elsif ($name eq 'service') {
 915             $value = lc $value;
 916             my $valid_service = qr{http|https|ldap|ftp|smtp|pop|imap|nntp|dns|mysql|pgsql|sip|none};
 917             if (!defined $value || $value !~ /^(?:$valid_service)$/) {
 918                 config_error($line, 'ERR0106', $config);
 919             }
 920         }
 921         elsif ($name eq 'httpmethod') {
 922             my $valid_method = qr{GET|HEAD};
 923             $value = uc $value;
 924             if (!defined $value || $value !~ /^(?:$valid_method)$/) {
 925                 config_error($line, 'ERR0110', $config);
 926             }
 927         }
 928         elsif ($name eq 'fallback') {
 929             my $fallback = parse_fallback($line, $value, $config);
 930             $value = {tcp => $fallback};
 931         }
 932         elsif ( $name eq 'quiescent'
 933              || $name eq 'accesslog') {
 934             $value = defined $value && $value =~ /^yes$/i ? 1
 935                    : defined $value && $value =~ /^no$/i  ? 0
 936                    :                                        undef
 937                    ;
 938             if (!defined $value) {
 939                 config_error($line, 'ERR0102', $config);
 940             }
 941         }
 942         elsif ($name eq 'module') {
 943             my $module = undef;
 944             my $option = undef;
 945             if (defined $value) {
 946                 $value =~ s/["']//g;
 947                 ($module, $option) = split /\s+/, $value, 2;
 948             }
 949             if ( $module =~ /[^a-z]/ ) {
 950                 config_error($line, 'ERR0111', $config);
 951             }
 952             $value = {name => $module, option => $option};
 953         }
 954         elsif ($name eq 'sorryserver') {
 955             my $forward = 'masq';
 956             if ($value =~ /^(\S+)\s+(\S+)/) {
 957                 $value = $1;
 958                 $forward = lc $2;
 959             }
 960             my $sorry_server = ld_gethostservbyname($value, 'tcp');
 961             if (!defined $sorry_server) {
 962                 config_error($line, 'ERR0114', $config);
 963             }
 964             if ($forward && $forward !~ /^(?:masq|tproxy)$/) {
 965                 config_error($line, 'ERR0107', $config);
 966             }
 967             $sorry_server->{forward} = $forward;
 968             $value = $sorry_server;
 969         }
 970         elsif (    $name eq 'qosup'
 971                 || $name eq 'qosdown' ) {
 972             $value = uc $value;
 973             if ( !defined $value || ($value ne '0' && $value !~ /^[1-9]\d{0,2}[KMG]$/) ) {
 974                 config_error($line, 'ERR0113', $config);
 975             }
 976         }
 977         elsif (    $name eq 'realdowncallback'
 978                 || $name eq 'realrecovercallback' ) {
 979             if (!defined $value || !-f $value || !-x $value) {
 980                 config_error($line, 'ERR0117', $config);
 981             }
 982         }
 983         elsif ( $name eq 'socketoption') {
 984             $value = lc $value;
 985             $value =~ s/ //g;
 986             if (!defined $value) {
 987                 config_error($line, 'ERR0124', $config);
 988             }
 989             my @option_value = split /,/, $value;
 990             # OPTION:transparent,deferaccept,nodelay,cork,quickackon|quickackoff
 991             for my $option (@option_value) {
 992                 $option =~ s/ //g;
 993                 if($option !~ /^transparent|deferaccept|nodelay|cork|quickackon|quickackoff$/) {
 994                     config_error($line, 'ERR0124', $config);
 995                 }
 996             }
 997         }
 998         elsif ($name eq 'sslconfigfile') {
 999             if (!defined $value || !-f $value) {
1000                 config_error($line, 'ERR0116', $config);
1001             }
1002         }
1003         elsif ( $name eq 'accesslogfile') {
1004             if (!defined $value || $value !~ /^\/.*/) {
1005                 config_error($line, 'ERR0116', $config);
1006             }
1007
1008         }
1009         elsif ($name eq 'accesslog_rotate_type') {
1010             $value = lc $value;
1011             my $valid_rotate_type = qr{date|size|datesize};
1012             if (!defined $value || $value !~ /^(?:$valid_rotate_type)$/) {
1013                 config_error($line, 'ERR0124', $config);
1014             }
1015         }
1016         elsif ($name eq 'accesslog_rotate_max_backup_index') {
1017             if (!defined $value || $value !~ /^\d+$/ || $value <= 0 || $value >= 13) {
1018                 config_error($line, 'ERR0126', $config);
1019             }
1020         }
1021         elsif ($name eq 'accesslog_rotate_max_filesize') {
1022             $value = uc $value;
1023             if ( !defined $value || ($value ne '0' && $value !~ /^([1-9]\d{0,2}[KMG]|\d{1,3})$/) ) {
1024                 config_error($line, 'ERR0127', $config);
1025             }
1026         }
1027         elsif ($name eq 'accesslog_rotate_rotation_timing') {
1028             $value = lc $value;
1029             my $valid_rotation_timing = qr{year|month|week|date|hour};
1030             if (!defined $value || $value !~ /^(?:$valid_rotation_timing)$/) {
1031                 config_error($line, 'ERR0128', $config);
1032             }
1033         }
1034         elsif ($name eq 'accesslog_rotate_rotation_timing_value') {
1035             my $check = undef;
1036             $value =~ s/["']//g;
1037             if (!defined $value ) {
1038                 config_error($line, 'ERR0129', $config);
1039             }
1040             if ($value =~ /^\d{1,2}\/\d{1,2}\s\d{1,2}:\d{1,2}$/) {
1041                 ## MM/dd hh:mm Check
1042                 $check = 1;
1043             }
1044             elsif ($value =~ /^\d{1,2}\s\d{1,2}:\d{1,2}$/) {
1045                 ## dd hh:mm Check
1046                 $check = 1;
1047             }
1048             elsif ($value =~ /^(sun|mon|tue|wed|thu|fri|sat)\s\d{1,2}:\d{1,2}$/i) {
1049                 ## <week> hh:mm Check
1050                 $check = 1;
1051             }
1052             elsif ($value =~ /^\d{1,2}:\d{1,2}$/) {
1053                 ## hh:mm        Check
1054                 $check = 1;
1055             }
1056             elsif ($value =~ /^\d{1,2}$/) {
1057                 ## mm           Check
1058                 $check = 1;
1059             }
1060             if ( !defined $check ) {
1061                 config_error($line, 'ERR0129', $config);
1062             }
1063         }
1064         elsif ($name eq 'session_thread_pool_size') {
1065             if (!defined $value || $value !~ /^\d+$/ || $value == 0 ) {
1066                 config_error($line, 'ERR0101', $config);
1067             }
1068         }
1069     }
1070
1071     return ($name, $value);
1072 }
1073
1074 # check_require_module
1075 # Check service setting and require module.
1076 sub check_require_module {
1077     my %require_module = (
1078         http    => [ qw( LWP::UserAgent LWP::Debug ) ],
1079         https   => [ qw( LWP::UserAgent LWP::Debug Crypt::SSLeay ) ],
1080         ftp     => [ qw( Net::FTP ) ],
1081         smtp    => [ qw( Net::SMTP ) ],
1082         pop     => [ qw( Net::POP3 ) ],
1083         imap    => [ qw( Mail::IMAPClient ) ],
1084         ldap    => [ qw( Net::LDAP ) ],
1085         nntp    => [ qw( IO::Socket IO::Select6 ) ],
1086         dns     => [ qw( Net::DNS ) ],
1087         mysql   => [ qw( DBI DBD::mysql ) ],
1088         pgsql   => [ qw( DBI DBD::Pg ) ],
1089         sip     => [ qw( IO::Socket::INET IO::Socket::INET6 ) ],
1090         ping    => [ qw( Net::Ping ) ],
1091         connect => [ qw( IO::Socket::INET IO::Socket::INET6 ) ],
1092     );
1093
1094     for my $v ( @{ $CONFIG{virtual} } ) {
1095         next if !defined $v;
1096         next if ( !defined $v->{service} || !defined $v->{checktype} );
1097         my $check_service = q{};
1098         if ( $v->{checktype} eq 'negotiate' && $require_module{ $v->{service} } ) {
1099             $check_service = $v->{service};
1100         }
1101         elsif ($v->{checktype} eq 'ping' || $v->{checktype} eq 'connect') {
1102             $check_service = $v->{checktype};
1103         }
1104         else {
1105             next;
1106         }
1107         for my $module ( @{ $require_module{$check_service} } ) {
1108             my $module_path = $module . '.pm';
1109             $module_path =~ s{::}{/}g;
1110             eval {
1111                 require $module_path;
1112             };
1113             if ($EVAL_ERROR) {
1114                 config_error(0, 'ERR0123', $module, $check_service);
1115             }
1116         }
1117     }
1118 }
1119
1120 # _ld_service_resolve
1121 # Set service name from port number
1122 # pre: vsrv: Virtual Service to resolve port
1123 #      port: port in the form
1124 # post: If $vsrv->{service} is not set, then set it to "http",
1125 #       "https", "ftp", "smtp", "pop", "imap", "ldap", "nntp" or "none"
1126 #       if $vsrv->{port} is 80, 443, 21, 25, 110, 143, 389 or
1127 #       any other value, respectivley
1128 # return: none
1129 sub _ld_service_resolve {
1130     my ($vsrv, $port) = @_;
1131
1132     my %servname;
1133     my @p = qw( 80   443   21  25   110 119  143  389  53  3306  5432  5060 );
1134     my @s = qw( http https ftp smtp pop nntp imap ldap dns mysql pgsql sip  );
1135     @servname{@p} = @s;
1136
1137     if (defined $vsrv && !defined $vsrv->{service} && defined $port) {
1138         $vsrv->{service} = exists $servname{$port} ? $servname{$port}
1139                          :                           'none'
1140                          ;
1141     }
1142 }
1143
1144 # parse_fallback
1145 # Parse a fallback server
1146 # pre: line: line number fallback server was read from
1147 #      fallback: Should be of the form
1148 #                ip_address|hostname[:port|:service_name] [masq|tproxy]
1149 #      config_line: line read from configuration file
1150 # post: fallback is parsed
1151 # return: Reference to hash of the form
1152 #         { server => blah, forward => blah }
1153 #         Debugging message will be reported and programme will exit
1154 #         on error.
1155 sub parse_fallback {
1156     my ($line, $fallback, $config_line) = @_;
1157
1158     if (!defined $fallback || $fallback !~ /^(\S+)(?:\s+(\S+))?$/) {
1159         config_error($line, 'ERR0114', $config_line);
1160     }
1161     my ($ip_port, $forward) = ($1, $2);
1162     $ip_port = ld_gethostservbyname($ip_port, 'tcp');
1163     if ( !defined $ip_port ) {
1164         config_error($line, 'ERR0114', $config_line);
1165     }
1166     if (defined $forward && $forward !~ /^(?:masq|tproxy)$/i) {
1167         config_error($line, 'ERR0107', $config_line);
1168     }
1169
1170     my %fallback = %REAL;
1171     $fallback{server} = $ip_port;
1172     $fallback{option}{forward} = get_forward_flag($forward);
1173
1174     return \%fallback;
1175 }
1176
1177 # parse_real
1178 # Parse a real server
1179 # pre: line: line number real server was read from
1180 #      real: Should be of the form
1181 #                ip_address|hostname[:port|:service_name] [masq|tproxy]
1182 #      config_line: line read from configuration file
1183 # post: real is parsed
1184 # return: Reference to array include real server hash reference
1185 #         [ {server...}, {server...} ... ]
1186 #         Debugging message will be reported and programme will exit
1187 #         on error.
1188 sub parse_real {
1189     my ($line, $real, $config_line) = @_;
1190
1191     my $ip_host = qr{\d+\.\d+\.\d+\.\d+|[a-z0-9.-]+|\[[a-zA-Z0-9:]+\]};
1192     my $port_service = qr{\d+|[a-z0-9-]+};
1193     if (    !defined $real
1194          || $real !~ /^
1195                       ($ip_host)             # ip or host
1196                       (?:->($ip_host))?      # range (optional)
1197                       (?::($port_service))?  # port or service (optional)
1198                       (?:\s+([a-z]+))?       # forwarding mode (optional)
1199                       (?:\s+(\d+))?          # weight (optional)
1200                       (?:\s+
1201                          ([^,\s]+)           # "request
1202                          \s*[ ,]\s*          #  separater
1203                          (\S+)               #  receive"
1204                       )?                     # (optional)
1205                       $/ix) {
1206         config_error($line, 'ERR0114', $config_line);
1207     }
1208     my ($ip1, $ip2, $port, $forward, $weight, $request, $receive)
1209      = (  $1,   $2,    $3,       $4,      $5,       $6,       $7);
1210     # set forward, weight and request-receive pair.
1211     my %real = %REAL;
1212     if (defined $forward) {
1213         $forward = lc $forward;
1214         if ($forward !~ /^(?:masq|tproxy)$/) {
1215             config_error($line, 'ERR0107', $config_line);
1216         }
1217         $real{forward} = $forward;
1218     }
1219     if (defined $weight) {
1220         $real{weight} = $weight;
1221     }
1222     if (defined $request && defined $receive) {
1223         $request =~ s/^\s*("|')(.*)\1\s*/$2/;
1224         $receive =~ s/^\s*("|')(.*)\1\s*/$2/;
1225         $real{request} = $request;
1226         $real{receive} = $receive;
1227     }
1228
1229     my $resolved_port = undef;
1230     if (defined $port) {
1231         $resolved_port = ld_getservbyname($port);
1232         if (!defined $resolved_port) {
1233             config_error($line, 'ERR0108', $config_line);
1234         }
1235     }
1236
1237     my $resolved_ip1 = ld_gethostbyname($ip1);
1238     if (!defined $resolved_ip1) {
1239         config_error($line, 'ERR0114', $config_line);
1240     }
1241
1242     my $resolved_ip2 = $resolved_ip1;
1243     if (defined $ip2) {
1244         $resolved_ip2 = ld_gethostbyname($ip2);
1245         if (!defined $resolved_ip2) {
1246             config_error($line, 'ERR0114', $config_line);
1247         }
1248     }
1249
1250     my ($ip_version , $int_ip1, $int_ip1_prefix ) = ip_to_int($resolved_ip1);
1251     my ($ip_version2, $int_ip2, $int_ip2_prefix ) = ip_to_int($resolved_ip2);
1252     my @reals = ();
1253     if ( defined $int_ip1 && defined $int_ip2 ) {
1254         if ($int_ip1 > $int_ip2) {
1255             config_error($line, 'ERR0115', $resolved_ip1, $resolved_ip2, $config_line);
1256         }
1257         elsif ($int_ip1 eq $int_ip2) {
1258             my %new_real = %real;
1259             $new_real{server}{ip  } = $resolved_ip1;
1260             $new_real{server}{port} = $resolved_port;
1261             push @reals, \%new_real;
1262         }
1263         else {
1264             for (my $int_ip = $int_ip1; $int_ip <= $int_ip2; $int_ip++) {
1265                 my %new_real = %real;
1266                 $new_real{server}{ip  } = int_to_ip($ip_version, $int_ip, $int_ip1_prefix);
1267                 $new_real{server}{port} = $resolved_port;
1268                 push @reals, \%new_real;
1269             }
1270         }
1271     }
1272     return \@reals;
1273 }
1274
1275 # config_error
1276 # Handle error during read configuration and validation check
1277 sub config_error {
1278     my ($line, $msg_code, @msg_args) = @_;
1279
1280     if ($DEBUG_LEVEL > 0 || $PROC_STAT{initialized} == 0) {
1281         my $msg = _message_only($msg_code, @msg_args);
1282         if (defined $line && $line > 0) {
1283             print {*STDERR} _message_only('ERR0121', $CONFIG_FILE{path}, $line, $msg) . "\n";
1284         }
1285         else {
1286             print {*STDERR} $msg . "\n";
1287         }
1288     }
1289     else {
1290         if ($line > 0) {
1291             ld_log( _message('ERR0121', $CONFIG_FILE{path}, $line, q{}) );
1292         }
1293         ld_log( _message($msg_code, @msg_args) );
1294     }
1295     if ( $PROC_STAT{initialized} == 0 ) {
1296         ld_exit(5, _message_only('ERR0002') );
1297     }
1298     else {
1299         die "Configuration error.\n";
1300     }
1301 }
1302
1303 # ld_setup
1304 # Check configuration value and set default value, overwrite global config value and so on.
1305 sub ld_setup {
1306     if ( defined $CONFIG{virtual} ) {
1307         for my $v ( @{ $CONFIG{virtual} } ) {
1308             next if !defined $v;
1309             if (defined $v->{protocol} && $v->{protocol} eq 'tcp') {
1310                 $v->{option}{protocol} = "-t";
1311             }
1312
1313             if ( defined $v->{option} && defined $v->{option}{protocol} && defined $v->{module} && defined $v->{module}{name} ) {
1314                 my $module_option = $v->{module}{name};
1315                 if ( defined $v->{module}{option} ) {
1316                     $module_option .= q{ } . $v->{module}{option};
1317                 }
1318                 $v->{option}{main} = sprintf "%s %s -m %s", $v->{option}{protocol}, get_ip_port($v), $module_option;
1319                 $v->{option}{flags} = $v->{option}{main};
1320                 if ( defined $v->{scheduler} ) {
1321                     $v->{option}{flags} .= ' -s ' . $v->{scheduler};
1322                 }
1323                 if ( defined $v->{maxconn} ) {
1324                     $v->{option}{flags} .= ' -u ' . $v->{maxconn};
1325                 }
1326                 if ( defined $v->{sorryserver} && defined $v->{sorryserver}{ip} && defined $v->{sorryserver}{port} ) {
1327                     $v->{option}{flags} .= ' -b ' . $v->{sorryserver}{ip} . ':' . $v->{sorryserver}{port};
1328                 }
1329                 if ( defined $v->{sorryserver}{forward} ) {
1330                     $v->{option}{flags} .= ' ' . get_forward_flag( $v->{sorryserver}{forward} );
1331                 }
1332                 if ( defined $v->{qosup} ) {
1333                     $v->{option}{flags} .= ' -Q ' . $v->{qosup};
1334                 }
1335                 if ( defined $v->{qosdown} ) {
1336                     $v->{option}{flags} .= ' -q ' . $v->{qosdown};
1337                 }
1338                 if ( defined $v->{sslconfigfile} ) {
1339                     $v->{option}{flags} .= ' -z ' . $v->{sslconfigfile};
1340                     $v->{other_virtual_key} .= ' ' . $v->{sslconfigfile};
1341                 }
1342                 else {
1343                     $v->{other_virtual_key} .= ' none';
1344                 }
1345                 if ( defined $v->{socketoption} ) {
1346                     $v->{option}{flags} .= ' -O ' . $v->{socketoption};
1347                     $v->{other_virtual_key} .= ' ' . $v->{socketoption};
1348                 }
1349                 else {
1350                     $v->{other_virtual_key} .= ' none';
1351                 }
1352                 if ( defined $v->{accesslog} ) {
1353                     $v->{option}{flags} .= ' -L ' . $v->{accesslog};
1354                 }
1355                 if ( defined $v->{accesslogfile} ) {
1356                     $v->{option}{flags} .= ' -a ' . $v->{accesslogfile};
1357                     $v->{other_virtual_key} .=  ' ' . $v->{accesslogfile};
1358                 }
1359                 else {
1360                     $v->{other_virtual_key} .= ' none';
1361                 }
1362                 my $option_key_flag = 0;
1363                 if ( defined $v->{accesslog_rotate_type} ) {
1364                     $v->{option}{flags}
1365                        .= ' --ac-rotate-type ' . $v->{accesslog_rotate_type};
1366                     $v->{other_virtual_key}
1367                        .= ' --ac-rotate-type ' . $v->{accesslog_rotate_type};
1368                     $option_key_flag = 1;
1369                 }
1370                 if ( defined $v->{accesslog_rotate_max_backup_index} ) {
1371                     $v->{option}{flags}
1372                        .= ' --ac-rotate-max-backup-index '
1373                              . $v->{accesslog_rotate_max_backup_index};
1374                     $v->{other_virtual_key}
1375                        .= ' --ac-rotate-max-backup-index '
1376                              . $v->{accesslog_rotate_max_backup_index};
1377                     $option_key_flag = 1;
1378                 }
1379                 if ( defined $v->{accesslog_rotate_max_filesize} ) {
1380                     $v->{option}{flags}
1381                        .= ' --ac-rotate-max-filesize '
1382                              . $v->{accesslog_rotate_max_filesize};
1383                     $v->{other_virtual_key}
1384                        .= ' --ac-rotate-max-filesize '
1385                              . $v->{accesslog_rotate_max_filesize};
1386                     $option_key_flag = 1;
1387                 }
1388                 if ( defined $v->{accesslog_rotate_rotation_timing} ) {
1389                     $v->{option}{flags}
1390                        .= ' --ac-rotate-rotation-timing '
1391                              . $v->{accesslog_rotate_rotation_timing};
1392                     $v->{other_virtual_key}
1393                        .= ' --ac-rotate-rotation-timing '
1394                              . $v->{accesslog_rotate_rotation_timing};
1395                     $option_key_flag = 1;
1396                 }
1397                 if ( defined $v->{accesslog_rotate_rotation_timing_value} ) {
1398                     $v->{option}{flags}
1399                        .= ' --ac-rotate-rotation-timing-value '
1400                           . q{"}. $v->{accesslog_rotate_rotation_timing_value}. q{"};
1401                     $v->{other_virtual_key}
1402                        .= ' --ac-rotate-rotation-timing-value '
1403                           .  $v->{accesslog_rotate_rotation_timing_value};
1404                     $option_key_flag = 1;
1405                 }
1406                 if ( $option_key_flag == 0 ) {
1407                     $v->{other_virtual_key} .= ' none';
1408                 }
1409                 if ( defined $v->{session_thread_pool_size} ) {
1410                     $v->{option}{flags} .= ' --session-thread-pool-size ' . $v->{session_thread_pool_size};
1411                 }
1412             }
1413
1414             if ( !defined $v->{fallback} && defined $CONFIG{fallback} ) {
1415                 $v->{fallback} = { %{ $CONFIG{fallback} } };
1416             }
1417             if ( defined $v->{fallback} ) {
1418                 for my $proto ( keys %{ $v->{fallback} } ) {
1419                     $v->{fallback}{$proto}{option}{flags} = '-r ' . get_ip_port( $v->{fallback}{$proto} )
1420                         . ' ' . $v->{fallback}{$proto}{option}{forward};
1421                 }
1422             }
1423             if (defined $v->{checktype} && $v->{checktype} =~ /^\d+$/) {
1424                 $v->{num_connects} = $v->{checktype};
1425                 $v->{checktype} = 'combined';
1426             }
1427
1428             if ( defined $v->{login} && $v->{login} eq q{} ) {
1429                 $v->{login} = defined $v->{service} && $v->{service} eq 'ftp' ? 'anonymous'
1430                             : defined $v->{service} && $v->{service} eq 'sip' ? 'l7directord@' . $PROC_ENV{hostname}
1431                             :                                                   q{}
1432                             ;
1433             }
1434             if ( defined $v->{passwd} && $v->{passwd} eq q{} ) {
1435                 $v->{passwd} = defined $v->{service} && $v->{service} eq 'ftp' ? 'l7directord@' . $PROC_ENV{hostname}
1436                              :                                                   q{}
1437                              ;
1438             }
1439
1440             if ( defined $v->{real} ) {
1441                 for my $r ( @{ $v->{real} } ) {
1442                     next if !defined $r;
1443                     if ( defined $r->{forward} ) {
1444                         $r->{option}{forward} = get_forward_flag( $r->{forward} );
1445                     }
1446                     if ( !defined $r->{weight} || $r->{weight} !~ /^\d+$/ ) {
1447                         $r->{weight} = 1;
1448                     }
1449
1450                     if ( !defined $r->{server}{port} ) {
1451                         $r->{server}{port} = $v->{server}{port};
1452                     }
1453
1454                     $r->{option}{flags} = '-r ' . get_ip_port($r) . ' ' . $r->{option}{forward};
1455
1456                     # build request URL
1457                     if ( defined $v->{service} && defined $r->{server} ) {
1458                         my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
1459                         my $ipaddress = $r->{server}{ip};
1460                         if ( is_ip6($ipaddress)){
1461                             $ipaddress = qq{ [$r->{server}{ip}] };
1462                         }
1463                         $r->{url} = sprintf "%s://%s:%s/",
1464                                             $v->{service}, $ipaddress, $port;
1465                         $r->{url} =~ s/\s//g;
1466                     }
1467                     if ( !defined $r->{request} && defined $v->{request} ) {
1468                         $r->{request} = $v->{request};
1469                     }
1470                     if ( !defined $r->{receive} && defined $v->{receive} ) {
1471                         $r->{receive} = $v->{receive};
1472                     }
1473                     if ( defined $r->{request} ) {
1474                         my $uri = $r->{request};
1475                         my $service = $v->{service};
1476                         if ( defined $v->{service} && $uri =~ m{^$service://} ) {
1477                             $r->{url} = $uri;
1478                         }
1479                         else {
1480                             $uri =~ s{^/+}{}g;
1481                             $r->{url} .= $uri;
1482                         }
1483                     }
1484
1485                     # set connect count for combine check
1486                     if (defined $v->{checktype} && $v->{checktype} eq 'combined') {
1487                         $r->{num_connects} = undef;
1488                     }
1489
1490                     $r->{fail_counts} = 0;
1491                     $r->{healthchecked} = 0;
1492                 }
1493             }
1494             if ( !defined $v->{checkcount} || $v->{checkcount} <= 0 ) {
1495                 $v->{checkcount} = $CONFIG{checkcount};
1496             }
1497             if ( !defined $v->{checktimeout} || $v->{checktimeout} <= 0 ) {
1498                 $v->{checktimeout} = $CONFIG{checktimeout};
1499             }
1500             if ( !defined $v->{negotiatetimeout} || $v->{negotiatetimeout} <= 0 ) {
1501                 $v->{negotiatetimeout} = $CONFIG{negotiatetimeout};
1502             }
1503             if ( !defined $v->{checkinterval} || $v->{checkinterval} <= 0 ) {
1504                 $v->{checkinterval} = $CONFIG{checkinterval};
1505             }
1506             if ( !defined $v->{retryinterval} || $v->{retryinterval} <= 0 ) {
1507                 $v->{retryinterval} = $CONFIG{retryinterval};
1508             }
1509             if ( !defined $v->{quiescent} ) {
1510                 $v->{quiescent} = $CONFIG{quiescent};
1511             }
1512         }
1513     }
1514
1515     if (defined $CONFIG{fallback}) {
1516         $CONFIG{fallback}{tcp}{option}{flags} = '-r ' . get_ip_port( $CONFIG{fallback}{tcp} )
1517             . ' ' . $CONFIG{fallback}{tcp}{option}{forward};
1518     }
1519 }
1520
1521 # Removed persistent and netmask related hash entries from the structure of l7vsadm since it is not used - NTT COMWARE
1522 # ld_read_l7vsadm
1523 # Parses the output of "l7vsadm -K -n" and puts into a structure of
1524 # the following from:
1525 #
1526 # {
1527 #   (vip_address:vport) protocol module_name module_key_value => {
1528 #     "scheduler" => scheduler,
1529 #     "real" => {
1530 #       rip_address:rport => {
1531 #         "forward" => forwarding_mechanism,
1532 #         "weight"  => weight
1533 #       },
1534 #       ...
1535 #     }
1536 #   },
1537 #   ...
1538 # }
1539 #
1540 # where:
1541 #   vip_address: IP address of virtual service
1542 #   vport: Port of virtual service
1543 #   module_name: Depicts the name of the module (For example, pfilter)
1544 #   module_key_value: Depicts the module key values (For example, --path-match xxxx)
1545 #   scheduler: Scheduler for virtual service
1546 #
1547 #   rip_address: IP address of real server
1548 #   rport: Port of real server
1549 #   forwarding_mechanism: Forwarding mechanism for real server.(masq or tproxy)
1550 #   weight: Weight of real server
1551 #
1552 # pre: none
1553 # post: l7vsadm -K -n is parsed
1554 # result: reference to structure detailed above.
1555 sub ld_read_l7vsadm {
1556     my $current_service = {};
1557     my $vip_id;
1558
1559     if ( !-f $PROC_ENV{l7vsadm} || !-x $PROC_ENV{l7vsadm} ) {
1560         ld_log( _message( 'FTL0101', $PROC_ENV{l7vsadm} ) );
1561         return $current_service;
1562     }
1563     # read status of current l7vsadm -K -n
1564     # -K indicates Key parameters of the module included.
1565     my $list_command = $PROC_ENV{l7vsadm} . " -K -n";
1566     my $cmd_result = qx{$list_command};
1567     my @list_line = split /\n/, $cmd_result;
1568     my $other_virtual_flag = 'off';
1569     my $other_virtual_count = 0;
1570     my $other_virtual_option = undef;
1571
1572     # skip below header
1573     # [cf] Layer-7 Virtual Server version 2.0.0-0
1574     # [cf] Prot LocalAddress:Port ProtoMod Scheduler Reschedule Protomod_key_string
1575     # [cf]   -> RemoteAddress:Port           Forward Weight ActiveConn InactConn
1576     shift @list_line; shift @list_line; shift @list_line;
1577
1578     for my $line (@list_line) {
1579         # check virtual service line format
1580         # [cf] TCP 192.168.0.4:12121 sessionless rr
1581         #      TCP [2031:130f:876a::130b]:1231 sessionless rr
1582        ####         ((\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}|\[[0-9a-fA-F:])(%.+)?\]:\d{1,5}) \s+ # ip port
1583         if (($line =~ /
1584                 ^           # top
1585                 (\w+) \s+   # 'TCP'
1586                 (\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}:\d{1,5}) \s+ # ip port
1587                 (\w+) \s+   # protocol module
1588                 \w+         # scheduler
1589                 $           # end
1590                 /x
1591
1592             )
1593            ||($line =~ /
1594                 ^           # top
1595                 (\w+) \s+   # 'TCP'
1596                 (\[[0-9a-fA-F:]+(?:%.+)?\]:\d{1,5}) \s+ # ip port
1597                 (\w+) \s+   # protocol module
1598                 \w+         # scheduler
1599                 $           # end
1600                 /x
1601
1602             )) {
1603             my ($proto, $ip_port, $module) = ($1, $2, $3);
1604             # vip_id MUST be same format as get_virtual_id_str
1605             $proto = lc $proto;
1606             $vip_id = "$proto:$ip_port:$module";
1607             $vip_id =~ s/\s+$//;
1608             $current_service->{$vip_id} = undef;
1609             $other_virtual_flag = 'on';
1610             $other_virtual_option = undef;
1611             $other_virtual_count = 0;
1612             next;
1613         }
1614         # check real server line format
1615         # [cf] -> 192.168.0.4:7780             Masq    1     10     123456
1616         if ((defined $vip_id && $line =~ /
1617                 ^           # top
1618                 \s+ -> \s+  # arrow
1619                 (\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}):(\d{1,5}) \s+ # ip port
1620                 (\w+) \s+   # 'Masq'
1621                 (\d+) \s+   # weight
1622                 \d+ \s+     # active connections
1623                 \d+ \s*     # inactive connections
1624                 $           # end
1625                 /x
1626             )
1627           ||(defined $vip_id && $line =~ /
1628                 ^           # top
1629                 \s+ -> \s+  # arrow
1630                 (\[[0-9a-fA-F:]+(?:%.+)?\]):(\d{1,5}) \s+ # ip port
1631                 (\w+) \s+   # 'Masq'
1632                 (\d+) \s+   # weight
1633                 \d+ \s+     # active connections
1634                 \d+ \s*     # inactive connections
1635                 $           # end
1636                 /x
1637             )) {
1638             my ($ip, $port, $forward, $weight) = ($1, $2, $3, $4);
1639             my $ip_port = "$ip:$port";
1640             my $real = {
1641                     server  => { ip => $ip, port => $port },
1642                     weight  => $weight,
1643                     forward => $forward,
1644                     option  => {
1645                                 flags   => "-r $ip_port",
1646                                 forward => get_forward_flag($forward),
1647                                 },
1648             };
1649             $other_virtual_flag = 'off';
1650             $current_service->{$vip_id}{$ip_port} = $real;
1651         }
1652         elsif ($other_virtual_flag eq 'on'){
1653             ##  SSL_config_file  value set          D->A Command
1654             ##  Socket option    value set          D->A Command
1655             ##  Access_log_flag  value set          E    Command
1656             ##  Access_log_file  value set          D->A Command
1657             ##  Access_log_rotate option value set  D->A Command
1658             if ($other_virtual_count != 2 ) {
1659                 $line =~ s/\s+/ /g;
1660                 $other_virtual_option .= $line;
1661                 $current_service->{$vip_id}{other_virtual_option}
1662                                         = $other_virtual_option;
1663             }
1664             $other_virtual_count++;
1665         }
1666     }
1667     return $current_service;
1668 }
1669
1670 # ld_operate_virtual
1671 # Operate virtual service on l7vsd by l7vsadm command.
1672 sub ld_operate_virtual {
1673     my ($v, $option, $success_code, $error_code) = @_;
1674     if (!defined $v || !defined $option || !defined $success_code || !defined $error_code) {
1675         ld_log( _message('ERR0501') );
1676         return;
1677     }
1678
1679     my $command = $PROC_ENV{l7vsadm} . " $option ";
1680     if ($option ne '-D') {
1681         $command .= $v->{option}{flags};
1682     }
1683     else {
1684         $command .= $v->{option}{main};
1685     }
1686     $command .= ' 2>&1';
1687
1688     my ($result, $output) = command_wrapper($command);
1689
1690     my $module_key = $v->{module}{name};
1691     if ( defined $v->{module}{key} ) {
1692         $module_key .= q{ } . $v->{module}{key};
1693     }
1694     if ($result == 0) {
1695         ld_log( _message($success_code, get_ip_port($v), $module_key) );
1696     }
1697     else {
1698         ($output) = split /\n/, $output, 2;
1699         ld_log( _message($error_code, get_ip_port($v), $module_key, $output) );
1700     }
1701 }
1702
1703 # ld_add_virtual
1704 # Call operate virtual with add option.
1705 sub ld_add_virtual {
1706     my $v = shift;
1707     ld_operate_virtual($v, '-A', 'INF0201', 'ERR0201');
1708 }
1709
1710 # ld_edit_virtual
1711 # Call operate virtual with edit option.
1712 sub ld_edit_virtual {
1713     my $v = shift;
1714     ld_operate_virtual($v, '-E', 'INF0202', 'ERR0202');
1715 }
1716
1717 # ld_delete_virtual
1718 # Call operate virtual with delete option.
1719 sub ld_delete_virtual {
1720     my $v = shift;
1721     ld_operate_virtual($v, '-D', 'INF0203', 'ERR0203');
1722 }
1723
1724 # ld_operate_real
1725 # Operate real server on l7vsd by l7vsadm command.
1726 sub ld_operate_real {
1727     my ($v, $r, $weight, $option, $success_code, $error_code) = @_;
1728     if (!defined $v || !defined $r || !defined $option || !defined $success_code || !defined $error_code) {
1729         ld_log( _message('ERR0501') );
1730         return;
1731     }
1732
1733     my $command
1734         = $PROC_ENV{l7vsadm} . " $option " . $v->{option}{main} . q{ } . $r->{option}{flags};
1735
1736     # replace weight value
1737     if (defined $weight) {
1738         $command .= ' -w ' . $weight;
1739     }
1740     $command .= ' 2>&1';
1741
1742     my ($result, $output) = command_wrapper($command);
1743
1744     my $module_key = $v->{module}{name};
1745     if ( defined $v->{module}{key} ) {
1746         $module_key .= q{ } . $v->{module}{key};
1747     }
1748     if ($result == 0) {
1749         ld_log( _message($success_code, get_ip_port($r), $r->{forward}, get_ip_port($v), $module_key, $weight) );
1750     }
1751     else {
1752         ($output) = split /\n/, $output, 2;
1753         ld_log( _message($error_code, get_ip_port($r), $r->{forward}, get_ip_port($v), $module_key, $output) );
1754     }
1755 }
1756
1757 # ld_add_real
1758 # Call operate real with add option.
1759 sub ld_add_real {
1760     my ($v, $r, $weight) = @_;
1761     ld_operate_real($v, $r, $weight, '-a', 'INF0204', 'ERR0204');
1762 }
1763
1764 # ld_edit_real
1765 # Call operate real with edit option.
1766 sub ld_edit_real {
1767     my ($v, $r, $weight) = @_;
1768     ld_operate_real($v, $r, $weight, '-e', 'INF0205', 'ERR0205');
1769 }
1770
1771 # ld_delete_real
1772 # Call operate real with delete option.
1773 sub ld_delete_real {
1774     my ($v, $r) = @_;
1775     ld_operate_real($v, $r, undef, '-d', 'INF0206', 'ERR0206');
1776 }
1777
1778 # ld_start
1779 # Check l7vsd by l7vsadm command and create virtual service on l7vsd.
1780 sub ld_start {
1781     # read status of current l7vsadm -K -n
1782     my $current_service = ld_read_l7vsadm();
1783     if (!defined $current_service ) {
1784         ld_log( _message('FTL0201') );
1785         return;
1786     }
1787
1788     my %old_health_check = %HEALTH_CHECK;
1789     %HEALTH_CHECK = ();
1790
1791     # make sure virtual servers are up to date
1792     if ( defined $CONFIG{virtual} ) {
1793         for my $nv ( @{ $CONFIG{virtual} } ) {
1794             my $vip_id = get_virtual_id_str($nv);
1795             if (!defined $vip_id) {
1796                 ld_log( _message('ERR0502') );
1797                 return;
1798             }
1799
1800             if ( exists( $current_service->{$vip_id} )){
1801                 if(( defined $current_service->{$vip_id}{other_virtual_option}
1802                   && defined $nv->{other_virtual_key})
1803                   && $current_service->{$vip_id}{other_virtual_option}
1804                    ne  $nv->{other_virtual_key} ) {
1805                     ld_delete_virtual($nv);
1806                     # no such service, create a new one
1807                     ld_add_virtual($nv);
1808                 }
1809                 else {
1810                     # service already exists, modify it
1811                     ld_edit_virtual($nv);
1812                 }
1813             }
1814             else {
1815                 my $newipport;
1816                 my $del_vip_id;
1817                 # Module Change
1818                 for my $check ( keys  %{ $current_service }  ){
1819                     next if !defined $check ;
1820                     $del_vip_id = $check;
1821                     # protcol name delete
1822                     $check =~ s/(^[\w]+:)//;
1823                     ## module name delete
1824                     $check =~ s/(:[\w]+$)//;
1825                     $newipport = get_ip_port($nv);
1826                     if ( $check eq $newipport) {
1827                         for ( @{ $CONFIG{old_virtual} } ) {
1828                             my $virtual_id = get_virtual_id_str($_);
1829                             next if !defined $virtual_id ;
1830                             if ( $del_vip_id eq $virtual_id ) {
1831                                 ld_delete_virtual($_);
1832                                 delete $current_service->{$del_vip_id};
1833                             }
1834                         }
1835                     }
1836                 }
1837                 # no such service, create a new one
1838                 ld_add_virtual($nv);
1839             }
1840
1841             my $or = $current_service->{$vip_id} || {};
1842
1843             # Not delete fallback server from l7vsd if exist
1844             my $fallback = fallback_find($nv);
1845             if (defined $fallback) {
1846                 my $fallback_ip_port = get_ip_port( $fallback->{ $nv->{protocol} } );
1847                 delete $or->{$fallback_ip_port};
1848                 fallback_on($nv);
1849             }
1850
1851             if ( defined $nv->{real} ) {
1852                 CHECK_REAL:
1853                 for my $nr ( @{ $nv->{real} } ) {
1854                     delete $or->{ get_ip_port($nr) };
1855
1856                     my $health_check_id = get_health_check_id_str($nv, $nr);
1857                     if (!defined $health_check_id) {
1858                         ld_log( _message('ERR0503') );
1859                         return;
1860                     }
1861
1862                     # search same health check process
1863                     if ( exists $HEALTH_CHECK{$health_check_id} ) {
1864                         # same health check process exist
1865                         # then check real server and virtual service ($r, $v)
1866                         for my $v_r_pair ( @{ $HEALTH_CHECK{$health_check_id}{manage} } ) {
1867                             # completely same. check next real server
1868                             next CHECK_REAL if ($nv eq $v_r_pair->[0] && $nr eq $v_r_pair->[1]);
1869                         }
1870
1871                         # add real server and virtual service to management list
1872                         push @{ $HEALTH_CHECK{$health_check_id}{manage} }, [$nv, $nr];
1873                     }
1874                     else {
1875                         # add to health check process list
1876                         $HEALTH_CHECK{$health_check_id}{manage} = [ [$nv, $nr] ];
1877                     }
1878                 }
1879             }
1880
1881             my $work_ip = undef;
1882             # remove remaining entries for real servers
1883             for my $remove_real_ip_port (keys %$or) {
1884                 if ( 'other_virtual_option' eq $remove_real_ip_port ){
1885                     next;
1886                 }
1887                 $work_ip = $or->{$remove_real_ip_port}{server}{ip};
1888                 if ( !is_ip ($work_ip)
1889                   && !is_ip6($work_ip)){
1890                     next;
1891                 }
1892                 ld_delete_real( $nv, $or->{$remove_real_ip_port} );
1893                 delete $or->{$remove_real_ip_port};
1894             }
1895
1896             delete $current_service->{$vip_id};
1897         }
1898     }
1899
1900     # terminate old health check process
1901     # TODO should compare old and new, and only if different then re-create process...
1902     for my $id (keys %old_health_check) {
1903         # kill old health check process
1904         if ( defined $old_health_check{$id}{pid} ) {
1905             # TODO cannot kill process during pinging to unreachable host?
1906             {
1907                 local $SIG{ALRM} = sub { die; };
1908                 kill 15, $old_health_check{$id}{pid};
1909                 eval {
1910                     alarm 3;
1911                     waitpid $old_health_check{$id}{pid}, 0;
1912                     alarm 0;
1913                 };
1914                 alarm 0;
1915                 if ($EVAL_ERROR) {
1916                     kill 9, $old_health_check{$id}{pid};
1917                     waitpid $old_health_check{$id}{pid}, WNOHANG;
1918                 }
1919             }
1920         }
1921     }
1922
1923     # remove remaining entries for virtual servers
1924     if ( defined $CONFIG{old_virtual} ) {
1925         for my $nv ( @{ $CONFIG{old_virtual} } ) {
1926             my $vip_id = get_virtual_id_str($nv);
1927             next if !defined $vip_id ;
1928             if ( exists $current_service->{$vip_id} ) {
1929                 # service still exists, remove it
1930                 ld_delete_virtual($nv);
1931             }
1932         }
1933     }
1934     delete $CONFIG{old_virtual};
1935 }
1936
1937 # ld_cmd_children
1938 # Run l7directord command to child process.
1939 # Child process is not health check process,
1940 # but sub config (specified by configuration with `execute') process.
1941 sub ld_cmd_children {
1942     my $command_type = shift;
1943     my $execute = shift;
1944
1945     # instantiate other l7directord, if specified
1946     if (!defined $execute) {
1947         if ( defined $CONFIG{execute} ) {
1948             for my $sub_config ( keys %{ $CONFIG{execute} } ) {
1949                 if (defined $command_type && defined $sub_config) {
1950                     my $command = $PROC_ENV{l7directord} . " $sub_config $command_type";
1951                     system_wrapper($command);
1952                 }
1953             }
1954         }
1955     }
1956     else {
1957         for my $sub_config ( keys %$execute ) {
1958             if (defined $command_type && defined $sub_config) {
1959                 my $command = $PROC_ENV{l7directord} . " $sub_config $command_type";
1960                 system_wrapper($command);
1961             }
1962         }
1963     }
1964 }
1965
1966 # ld_stop
1967 # Remove virtual service for stopping this program.
1968 sub ld_stop {
1969     my $srv = ld_read_l7vsadm();
1970     if (!defined $srv) {
1971         ld_log( _message('FTL0201') );
1972         return;
1973     }
1974     if ( defined $CONFIG{virtual} ) {
1975         for my $v ( @{ $CONFIG{virtual} } ) {
1976             my $vid = get_virtual_id_str($v);
1977             if (!defined $vid) {
1978                 ld_log( _message('ERR0502') );
1979                 return;
1980             }
1981             if ( exists $srv->{$vid} ) {
1982                 for my $rid ( keys %{ $srv->{$vid} } ) {
1983                     if ( defined $rid
1984                       &&(!is_ip ($rid)
1985                       && !is_ip6($rid))){
1986                         next;
1987                     }
1988                     ld_delete_real( $v, $srv->{$vid}{$rid} );
1989                 }
1990             }
1991             ld_delete_virtual($v);
1992         }
1993     }
1994 }
1995
1996 # ld_main
1997 # Main function of this program.
1998 # Create virtual service and loop below 3 steps.
1999 # 1. Check health check sub process and (re-)create sub process as needed
2000 # 2. Check signal in sleep and start to terminate program or reload config as needed
2001 # 3. Check config file and reload config as needed
2002 sub ld_main {
2003     ld_start();
2004
2005     # Main failover checking code
2006     MAIN_LOOP:
2007     while (1) {
2008         # manage real server check process.
2009         REAL_CHECK:
2010         while (1) {
2011             my @id_lists = check_child_process();
2012             # if child process is not running
2013             if (@id_lists) {
2014                 create_check_process(@id_lists);
2015             }
2016             my $signal = sleep_and_check_signal( $CONFIG{configinterval} );
2017             last MAIN_LOOP  if defined $signal && $signal eq 'halt';
2018             last REAL_CHECK if defined $signal && $signal eq 'reload';
2019             last REAL_CHECK if check_cfgfile();
2020         }
2021
2022         # reload config
2023         reread_config();
2024     }
2025
2026     # signal TERM to child process
2027     for my $id (keys %HEALTH_CHECK) {
2028         if ( defined $HEALTH_CHECK{$id}{pid} ) {
2029             # TODO cannot kill process during pinging to unreachable host?
2030             {
2031                 local $SIG{ALRM} = sub { die; };
2032                 kill 15, $HEALTH_CHECK{$id}{pid};
2033                 eval {
2034                     alarm 3;
2035                     waitpid $HEALTH_CHECK{$id}{pid}, 0;
2036                     alarm 0;
2037                 };
2038                 alarm 0;
2039                 if ($EVAL_ERROR) {
2040                     kill 9, $HEALTH_CHECK{$id}{pid};
2041                     waitpid $HEALTH_CHECK{$id}{pid}, WNOHANG;
2042                 }
2043             }
2044         }
2045     }
2046     ld_stop();
2047 }
2048
2049 # check_child_process
2050 # Check health check process by signal zero.
2051 # return: Health check id list that (re-)created later.
2052 sub check_child_process {
2053     my @down_process_ids = ();
2054     for my $id (sort keys %HEALTH_CHECK) {
2055         if ( !defined $HEALTH_CHECK{$id}{pid} ) {
2056             # not create ever
2057             ld_log( _message('INF0401', $id) );
2058             push @down_process_ids, $id;
2059             next;
2060         }
2061         # signal 0
2062         my $signaled = kill 0, $HEALTH_CHECK{$id}{pid};
2063         if ($signaled != 1) {
2064             # maybe killed from outside
2065             ld_log( _message('ERR0603', $HEALTH_CHECK{$id}{pid}, $id) );
2066             push @down_process_ids, $id;
2067             next;
2068         }
2069     }
2070     return @down_process_ids;
2071 }
2072
2073 # create_check_process
2074 # Fork health check sub process.
2075 # And health check sub process run health_check sub function.
2076 sub create_check_process {
2077     my @id_lists = @_;
2078     for my $health_check_id (@id_lists) {
2079         my $pid = fork();
2080         if ($pid > 0) {
2081             ld_log( _message('INF0402', $pid, $health_check_id) );
2082             $HEALTH_CHECK{$health_check_id}{pid} = $pid;
2083         }
2084         elsif ($pid == 0) {
2085             $PROC_STAT{parent_pid} = $PROC_STAT{pid};
2086             $PROC_STAT{pid} = $PID;
2087             health_check( $HEALTH_CHECK{$health_check_id}{manage} );
2088         }
2089         else {
2090             ld_log( _message('ERR0604', $health_check_id) );
2091         }
2092         sleep 1;
2093     }
2094 }
2095
2096 # health_check
2097 # Main function of health check process.
2098 # Loop below.
2099 # 1. Health check.
2100 # 2. Status change and reflect to l7vsd as needed.
2101 # 3. Check signal in sleep.
2102 # pre: v_r_list: reference list of virtual service and real server pair
2103 #     $v_r_list = [ [$virtual, $real], [$virtual, $real], ... ];
2104 # return: none
2105 #         MUST use POSIX::_exit when terminate sub process.
2106 sub health_check {
2107     my $v_r_list = shift;
2108     if (!defined $v_r_list) {
2109         ld_log( _message('ERR0501') );
2110         ld_log( _message('FTL0001') );
2111         POSIX::_exit(1);
2112     }
2113
2114     # you can use any virtual, real pair in $v_r_list.
2115     my ($v, $r) = @{ $v_r_list->[0] };
2116     if (!defined $v || !defined $r) {
2117         ld_log( _message('FTL0002') );
2118         POSIX::_exit(2);
2119     }
2120
2121     my $health_check_func = get_check_func($v);
2122     my $current_status = get_status($v_r_list);
2123
2124     my $status = 'STARTING';
2125     my $type = $v->{checktype} eq 'negotiate' ? $v->{service}
2126              : $v->{checktype} eq 'combined'  ? $v->{service} . '(combined)'
2127              :                                  $v->{checktype}
2128              ;
2129     $PROGRAM_NAME = 'l7directord: ' . $type . ':' . get_ip_port($r) . ':' . $status;
2130
2131     while (1) {
2132         # health check
2133         my $service_status = &$health_check_func($v, $r);
2134
2135         if ($service_status == $SERVICE_DOWN) {
2136             undef $r->{num_connects};
2137             if (!defined $current_status || $current_status == $SERVICE_UP) {
2138                 $r->{fail_counts}++;
2139                 if ($r->{fail_counts} >= $v->{checkcount}) {
2140                     ld_log( _message( 'ERR0602', get_ip_port($r) ) );
2141                     service_set($v_r_list, 'down');
2142                     $current_status = $SERVICE_DOWN;
2143                     $status = 'DOWN';
2144                     $r->{fail_counts} = 0;
2145                 }
2146                 else {
2147                     ld_log( _message( 'WRN1001', get_ip_port($r), $v->{checkcount} - $r->{fail_counts} ) );
2148                     $status = sprintf "NG[%d/%d]", $r->{fail_counts}, $v->{checkcount};
2149                 }
2150             }
2151         }
2152         if ($service_status == $SERVICE_UP) {
2153             $r->{fail_counts} = 0;
2154             if (!defined $current_status || $current_status == $SERVICE_DOWN) {
2155                 ld_log( _message( 'ERR0601', get_ip_port($r) ) );
2156                 service_set($v_r_list, 'up');
2157                 $current_status = $SERVICE_UP;
2158             }
2159             $status = 'UP';
2160         }
2161
2162         $PROGRAM_NAME = 'l7directord: ' . $type . ':' . get_ip_port($r) . ':' . $status;
2163
2164         my $sleeptime = $r->{fail_counts} ? $v->{retryinterval} : $v->{checkinterval};
2165         last if (sleep_and_check_signal($sleeptime, 1) eq 'halt');
2166
2167         my $parent_process = kill 0, $PROC_STAT{parent_pid};
2168         if ($parent_process != 1) {
2169             ld_log( _message( 'FTL0003', $PROC_STAT{parent_pid} ) );
2170             POSIX::_exit(3);
2171         }
2172     }
2173
2174     ld_log( _message('INF0007') );
2175     POSIX::_exit(0);
2176 }
2177
2178 # sleep_and_check_signal
2179 # Check signal flag each 0.1 secound with sleeping specified seconds.
2180 sub sleep_and_check_signal {
2181     my ($sec, $is_child) = @_;
2182     if (!defined $sec || $sec !~ /^\d+$/) {
2183         ld_log( _message('ERR0501') );
2184         return 'halt';
2185     }
2186
2187     my $sleeped = 0;
2188     while ($sec > $sleeped) {
2189         # non-blocking wait for zombie process
2190         waitpid(-1, WNOHANG); # TODO should move to sigchld handler?
2191
2192         if ($is_child) {
2193             if ( defined $PROC_STAT{halt} ) {
2194                 ld_log( _message( 'WRN0001', $CONFIG_FILE{path}, $PROC_STAT{halt} ) );
2195                 return 'halt';
2196             }
2197         }
2198         else {
2199             if ( defined $PROC_STAT{halt} ) {
2200                 ld_log( _message( 'WRN0001', $CONFIG_FILE{path}, $PROC_STAT{halt} ) );
2201                 return 'halt';
2202             }
2203             if ( defined $PROC_STAT{reload} ) {
2204                 ld_log( _message( 'WRN0002', $CONFIG_FILE{path}, $PROC_STAT{reload} ) );
2205                 undef $PROC_STAT{reload};
2206                 return 'reload';
2207             }
2208         }
2209         sleep 0.1;
2210         $sleeped += 0.1;
2211     }
2212     return 'run';
2213 }
2214
2215 # get_check_func
2216 # Determine check function by checktype and service.
2217 sub get_check_func {
2218     my $v = shift;
2219     if (!defined $v) {
2220         ld_log( _message('ERR0501') );
2221         return \&check_off;
2222     }
2223
2224     my $type = $v->{checktype};
2225     my $service_func = {
2226         http  => \&check_http,
2227         https => \&check_http,
2228         pop   => \&check_pop,
2229         imap  => \&check_imap,
2230         smtp  => \&check_smtp,
2231         ftp   => \&check_ftp,
2232         ldap  => \&check_ldap,
2233         nntp  => \&check_nntp,
2234         dns   => \&check_dns,
2235         sip   => \&check_sip,
2236         mysql => \&check_mysql,
2237         pgsql => \&check_pgsql,
2238     };
2239
2240     if ( defined $type && ($type eq 'negotiate' || $type eq 'combined') ) {
2241         if (defined $v->{service} && exists $service_func->{ $v->{service} } ) {
2242             my $negotiate_func = $service_func->{ $v->{service} };
2243             if ($type eq 'negotiate') {
2244                 return $negotiate_func;
2245             }
2246             elsif ($type eq 'combined') {
2247                 my $combined_func =  make_combined_func($negotiate_func);
2248                 return $combined_func;
2249             }
2250         }
2251         else {
2252             return \&check_none;
2253         }
2254     }
2255
2256     if (defined $type && $type eq 'custom') {
2257         my $custom_func = make_custom_func( $v->{customcheck} );
2258         return $custom_func;
2259     }
2260
2261     if (defined $type && $type eq 'connect') {
2262         if (defined $v->{protocol} && $v->{protocol} eq 'tcp') {
2263             return \&check_connect;
2264         }
2265         else {
2266             return \&check_ping;
2267         }
2268     }
2269
2270     if (defined $type && $type eq 'ping') {
2271         return \&check_ping;
2272     }
2273
2274     if (defined $type && $type eq 'off') {
2275         return \&check_off;
2276     }
2277
2278     if (defined $type && $type eq 'on') {
2279         return \&check_on;
2280     }
2281
2282     return \&check_none;
2283 }
2284
2285 # make_combined_func
2286 # Create combined function.
2287 sub make_combined_func {
2288     my $negotiate_func = shift;
2289     if (!defined $negotiate_func) {
2290         ld_log( _message('ERR0504') );
2291         return \&check_connect;
2292     }
2293
2294     # closure
2295     my $combined_func = sub {
2296         my ($v, $r) = @_;
2297         my $timing    = $v->{num_connects};
2298         my $connected = $r->{num_connects};
2299
2300         if (!defined $connected ||
2301             (defined $timing && $timing <= $connected) ) {
2302             $r->{num_connects} = 0;
2303             return &$negotiate_func($v, $r);
2304         }
2305         else {
2306             $r->{num_connects}++;
2307             return check_connect($v, $r);
2308         }
2309     };
2310
2311     return $combined_func;
2312 }
2313
2314 # make_custom_func
2315 # Create custom check function.
2316 sub make_custom_func {
2317     my $customcheck = shift;
2318     if (!defined $customcheck) {
2319         ld_log( _message('ERR0505') );
2320         return \&check_off;
2321     }
2322
2323     # closure
2324     my $custom_func = sub {
2325         my ($v, $r) = @_;
2326         my $status = get_status([[$v, $r]]);
2327         my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2328         my $ip_port  = $r->{server}{ip} . ':' . $port;
2329
2330         # expand macro
2331         $customcheck =~ s/_IP_/$r->{server}{ip}/g;
2332         $customcheck =~ s/_PORT_/$port/g;
2333
2334         my $res;
2335         {
2336             local $SIG{__DIE__} = 'DEFAULT';
2337             local $SIG{ALRM} = sub { die "custom check timeout\n"; };
2338             eval {
2339                 alarm $v->{checktimeout};
2340                 $res = system_wrapper($customcheck);
2341                 alarm 0;
2342             };
2343             alarm 0;
2344             if ($EVAL_ERROR) {
2345                 ld_log( _message('WRN3301', $v->{checktimeout}, $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2346                 return $SERVICE_DOWN;
2347             }
2348         }
2349         if ($res) {
2350                 ld_log( _message('WRN3302', $customcheck, $res) ) if (!defined $status || $status eq $SERVICE_UP);
2351                 return $SERVICE_DOWN;
2352         }
2353         ld_log( _message('WRN0215', $ip_port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2354         return $SERVICE_UP;
2355     };
2356
2357     return $custom_func;
2358 }
2359
2360 # check_http
2361 # HTTP service health check.
2362 # Send GET/HEAD request, and check response
2363 sub check_http {
2364     require LWP::UserAgent;
2365     require LWP::Debug;
2366     if ( $DEBUG_LEVEL > 2 ) {
2367         LWP::Debug::level('+');
2368     }
2369     my ( $v, $r ) = @_;
2370     my $status = get_status([[$v, $r]]);
2371
2372     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2373
2374     if ( $r->{url} !~ m{^https?://([^:/]+)} ) {
2375         ld_log( _message( 'WRN1101', $r->{url}, $r->{server}{ip}, $port ) ) if (!defined $status || $status eq $SERVICE_UP);
2376         return $SERVICE_DOWN;
2377     }
2378     my $host = $1;
2379     my $virtualhost = defined $v->{virtualhost} ? $v->{virtualhost} : $host;
2380
2381     ld_debug(2, "check_http: url=\"$r->{url}\" " . "virtualhost=\"$virtualhost\"");
2382     my $status_line ;
2383
2384     if ( is_ip($r->{server}{ip})){
2385         my $ua = LWP::UserAgent->new( timeout => $v->{negotiatetimeout} );
2386         my $req = new HTTP::Request( $v->{httpmethod}, $r->{url}, [ Host => $virtualhost ] );
2387         my $res;
2388         {
2389             # LWP makes ungaurded calls to eval
2390             # which throw a fatal exception if they fail
2391             local $SIG{__DIE__} = 'DEFAULT';
2392             local $SIG{ALRM} = sub { die "Can't connect to $r->{server}{ip}:$port (connect: timeout)\n"; };
2393             eval {
2394                 alarm $v->{negotiatetimeout};
2395                 $res = $ua->request($req);
2396                 alarm 0;
2397             };
2398             alarm 0;
2399         }
2400
2401         $status_line = $res->status_line;
2402         $status_line =~ s/[\r\n]//g;
2403
2404         my $response = $v->{httpmethod} eq "HEAD" ? $res->as_string : $res->content;
2405         my $recstr = $r->{receive};
2406         if (!$res->is_success) {
2407             ld_log( _message( 'WRN1102', $status_line, $r->{server}{ip}, $port ) ) if (!defined $status || $status eq $SERVICE_UP);
2408             return $SERVICE_DOWN;
2409         }
2410             elsif (defined $recstr && $response !~ /$recstr/) {
2411             ld_log( _message( 'WRN1103', $recstr, $r->{server}{ip}, $port ) ) if (!defined $status || $status eq $SERVICE_UP);
2412             ld_debug(3, "HTTP Response " . $response);
2413             ld_debug(2, "check_http: $r->{url} is down\n");
2414             return $SERVICE_DOWN;
2415         }
2416     }
2417     else{
2418         ## ipv6 Check
2419         ## Wget Comand Check
2420         my $https_option = '';
2421         if ( $v->{service} eq 'https'){
2422             $https_option = '--no-check-certificate';
2423         }
2424         my $recstr = $r->{receive};
2425         my $command = "/usr/bin/wget " . "-q -t 1 --timeout $v->{negotiatetimeout} $https_option ".  $r->{url} . ' -O - ';
2426         my ($result, $output) = command_wrapper( $command );
2427         if( $result ) {
2428             ld_log( _message( 'WRN1103', 'web', $r->{server}{ip}, $port ) ) if (!defined $status || $status eq $SERVICE_UP);
2429             return $SERVICE_DOWN;
2430         }
2431         elsif (defined $recstr && $output !~ /$recstr/) {
2432             ld_log( _message( 'WRN1103', $recstr, $r->{server}{ip}, $port ) ) if (!defined $status || $status eq $SERVICE_UP);
2433             ld_debug(2, "check_http: $r->{url} is down\n");
2434             return $SERVICE_DOWN;
2435         }
2436
2437         $status_line = '200 OK';
2438
2439     }
2440
2441     ld_debug(2, "check_http: $r->{url} is up\n");
2442     ld_log( _message( 'WRN0203', $status_line, $r->{server}{ip}, $port ) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2443     return $SERVICE_UP;
2444 }
2445
2446 # check_smtp
2447 # SMTP service health check.
2448 # Connect SMTP server and check first response
2449 sub check_smtp {
2450     require Net::SMTP;
2451     my ($v, $r) = @_;
2452     my $status = get_status([[$v, $r]]);
2453
2454     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2455
2456     ld_debug(2, "Checking http: server=$r->{server}{ip} port=$port");
2457     my $debug_flag = $DEBUG_LEVEL ? 1 : 0;
2458
2459     my $smtp = Net::SMTP->new(
2460         $r->{server}{ip},
2461         Port    => $port,
2462         Timeout => $v->{negotiatetimeout},
2463         Debug   => $debug_flag,
2464     );
2465     if (!$smtp) {
2466         ld_log( _message('WRN1201', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2467         return $SERVICE_DOWN;
2468     }
2469     $smtp->quit;
2470
2471     ld_log( _message('WRN0204', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2472     return $SERVICE_UP;
2473 }
2474
2475 # check_pop
2476 # POP3 service health check.
2477 # Connect POP3 server and login if user-pass specified.
2478 sub check_pop {
2479     require Net::POP3;
2480     my ($v, $r) = @_;
2481     my $status = get_status([[$v, $r]]);
2482
2483     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2484
2485     ld_debug(2, "Checking pop server=$r->{server}{ip} port=$port");
2486     my $debug_flag = $DEBUG_LEVEL ? 1 : 0;
2487
2488     my $pop = Net::POP3->new(
2489         $r->{server}{ip},
2490         Port    => $port,
2491         Timeout => $v->{negotiatetimeout},
2492         Debug   => $debug_flag,
2493     );
2494     if (!$pop) {
2495         ld_log( _message('WRN1301', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2496         return $SERVICE_DOWN;
2497     }
2498
2499     if ( defined $v->{login} && defined $v->{passwd} && $v->{login} ne q{} ) {
2500         $pop->user( $v->{login} );
2501         my $num = $pop->pass( $v->{passwd} );
2502         if (!defined $num) {
2503             ld_log( _message('WRN1302', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2504             $pop->quit();
2505             return $SERVICE_DOWN;
2506         }
2507     }
2508     $pop->quit();
2509
2510     ld_log( _message('WRN0205', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2511     return $SERVICE_UP;
2512 }
2513
2514 # check_imap
2515 # IMAP service health check.
2516 # Connect IMAP server and login if user-pass specified.
2517 sub check_imap {
2518     require Mail::IMAPClient;
2519     my ($v, $r) = @_;
2520     my $status = get_status([[$v, $r]]);
2521
2522     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2523
2524     ld_debug(2, "Checking imap server=$r->{server}{ip} port=$port");
2525     my $debug_flag = $DEBUG_LEVEL ? 1 : 0;
2526
2527     my $imap;
2528     {
2529         local $SIG{ALRM} = sub { die "Connection timeout\n"; };
2530         eval {
2531             alarm $v->{negotiatetimeout};
2532             $imap = Mail::IMAPClient->new(
2533                 Server   => $r->{server}{ip},
2534                 Port     => $port,
2535                 Timeout  => $v->{negotiatetimeout},
2536                 Debug    => $debug_flag,
2537             );
2538             alarm 0;
2539         };
2540         alarm 0;
2541         if ($EVAL_ERROR) {
2542             ld_log( _message('WRN1403', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2543             return $SERVICE_DOWN;
2544         }
2545     }
2546     if (!$imap) {
2547         ld_log( _message('WRN1401', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2548         return $SERVICE_DOWN;
2549     }
2550
2551     if ( defined $v->{login} && defined $v->{passwd} && $v->{login} ne q{} ) {
2552         $imap->User( $v->{login} );
2553         $imap->Password( $v->{passwd} );
2554         my $authres = $imap->login();
2555         if (!$authres) {
2556             ld_log( _message('WRN1402', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2557             $imap->logout();
2558             return $SERVICE_DOWN;
2559         }
2560     }
2561     $imap->logout();
2562
2563     ld_log( _message('WRN0206', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2564     return $SERVICE_UP;
2565 }
2566
2567 # check_ldap
2568 # LDAP service health check.
2569 # Connect LDAP server and search if base-DN specified by 'request'
2570 sub check_ldap {
2571     require Net::LDAP;
2572     my ($v, $r) = @_;
2573     my $status = get_status([[$v, $r]]);
2574
2575     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2576
2577     ld_debug(2, "Checking ldap server=$r->{server}{ip} port=$port");
2578     my $debug_flag = $DEBUG_LEVEL ? 15 : 0;
2579
2580     my $ldap = Net::LDAP->new(
2581         $r->{server}{ip},
2582         port    => $port,
2583         timeout => $v->{negotiatetimeout},
2584         debug   => $debug_flag,
2585     );
2586     if (!$ldap) {
2587         ld_log( _message('WRN1501', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2588         return $SERVICE_DOWN;
2589     }
2590
2591     my $mesg;
2592     {
2593         local $SIG{ALRM} = sub { die "Connection timeout\n"; };
2594         eval {
2595             alarm $v->{negotiatetimeout};
2596             $mesg = $ldap->bind;
2597             alarm 0;
2598         };
2599         alarm 0;
2600         if ($EVAL_ERROR) {
2601             ld_log( _message('WRN1502', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2602             return $SERVICE_DOWN;
2603         }
2604     }
2605     if ($mesg->is_error) {
2606         ld_log( _message('WRN1503', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2607         return $SERVICE_DOWN;
2608     }
2609
2610     if ( defined $r->{request} && $r->{request} ne q{} ) {
2611         ld_debug( 4, "Base : " . $r->{request} );
2612         my $result = $ldap->search(
2613             base   => $r->{request},
2614             scope  => 'base',
2615             filter => '(objectClass=*)',
2616         );
2617
2618         if ($result->count != 1) {
2619             ld_log( _message('WRN1504', $result->count, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2620             $ldap->unbind;
2621             return $SERVICE_DOWN;
2622         }
2623
2624         if ( defined $r->{receive} ) {
2625             my $href       = $result->as_struct;
2626             my @arrayOfDNs = keys %$href;
2627             my $recstr = $r->{receive};
2628             if ($recstr =~ /.+/ && $arrayOfDNs[0] !~ /$recstr/) {
2629                 ld_log( _message('WRN1505', $recstr, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2630                 $ldap->unbind;
2631                 return $SERVICE_DOWN;
2632             }
2633         }
2634     }
2635     $ldap->unbind;
2636
2637     ld_log( _message('WRN0207', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2638     return $SERVICE_UP;
2639 }
2640
2641 # check_nntp
2642 # NNTP service health check.
2643 # Connect NNTP server and check response start with '2**'
2644 sub check_nntp {
2645     require IO::Socket;
2646     require IO::Select;
2647     my ($v, $r) = @_;
2648     my $status = get_status([[$v, $r]]);
2649
2650     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2651
2652     ld_debug(2, "Checking nntp server=$r->{server}{ip} port=$port");
2653
2654     my $sock = ld_open_socket( $r->{server}{ip}, $port, $v->{protocol}, $v->{negotiatetimeout} );
2655     if (!$sock) {
2656         ld_log( _message('WRN1601', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2657         return $SERVICE_DOWN;
2658     }
2659
2660     ld_debug(3, "Connected to $r->{server}{ip} (port $port)");
2661     my $select = IO::Select->new();
2662     $select->add($sock);
2663     if ( !defined $select->can_read( $v->{negotiatetimeout} ) ) {
2664         ld_log( _message('WRN1602', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2665         $select->remove($sock);
2666         $sock->close;
2667         return $SERVICE_DOWN;
2668     }
2669
2670     my $buf;
2671     sysread $sock, $buf, 64;
2672     $select->remove($sock);
2673     $sock->close;
2674     my ($response) = split /[\r\n]/, $buf;
2675
2676     if ($response !~ /^2/) {
2677         ld_log( _message('WRN1603', $response, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2678         return $SERVICE_DOWN;
2679     }
2680
2681     ld_log( _message('WRN0208', $response, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2682     return $SERVICE_UP;
2683 }
2684
2685 # check_mysql
2686 # MySQL service health check.
2687 # call check_sql and use MySQL driver
2688 sub check_mysql {
2689     return check_sql(@_, 'mysql', 'database');
2690 }
2691
2692 # check_pgsql
2693 # PostgreSQL service health check.
2694 # call check_sql and use PostgreSQL driver
2695 sub check_pgsql {
2696     return check_sql(@_, 'Pg', 'dbname');
2697 }
2698
2699 # check_sql
2700 # DBI service health check.
2701 # Login DB and send query if query specified by 'request', check result row number same as 'receive'
2702 sub check_sql {
2703     require DBI;
2704     my ($v, $r, $dbd, $dbname) = @_;
2705     my $status = get_status([[$v, $r]]);
2706
2707     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2708
2709     if ( !defined $v->{login} || !defined $v->{passwd} || !defined $v->{database} ||
2710            $v->{login} eq q{} || $v->{database} eq q{} ) {
2711         ld_log( _message('WRN1701', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2712         return $SERVICE_DOWN;
2713     }
2714
2715     ld_debug(2, "Checking $v->{server}{ip} server=$r->{server}{ip} port=$port\n");
2716
2717     my $mask = POSIX::SigSet->new(SIGALRM);
2718     my $action = POSIX::SigAction->new(
2719         sub { die "Connection timeout\n" },
2720         $mask,
2721     );
2722     my $oldaction = POSIX::SigAction->new();
2723     sigaction(SIGALRM, $action, $oldaction);
2724
2725     my $dbh;
2726     eval {
2727         alarm $v->{negotiatetimeout};
2728
2729         DBI->trace(15) if $DEBUG_LEVEL;
2730         $dbh = DBI->connect( "dbi:$dbd:$dbname=$v->{database};host=$r->{server}{ip};port=$port", $v->{login}, $v->{passwd} );
2731         DBI->trace(0);
2732
2733         if (!defined $dbh) {
2734             alarm 0;
2735             sigaction(SIGALRM, $oldaction);
2736             ld_log( _message('WRN1702', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2737             die;
2738         }
2739
2740         local $dbh->{TraceLevel} = $DEBUG_LEVEL ? 15 : 0;
2741
2742         my $rows = 0;
2743
2744         if ( defined $r->{request} && $r->{request} ne q{} ) {
2745             my $sth  = $dbh->prepare( $r->{request} );
2746             $rows = $sth->execute;
2747             $sth->finish;
2748         }
2749
2750         $dbh->disconnect;
2751
2752         alarm 0;
2753         sigaction(SIGALRM, $oldaction);
2754
2755         if ( defined $r->{request} && $r->{request} ne q{} ) {
2756             ld_debug(4, "Database search returned $rows rows");
2757             if ($rows == 0) {
2758                 ld_log( _message('WRN1703', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2759                 die;
2760             }
2761             # If user defined a receive string (number of rows returned), only do
2762             # the check if the previous fetchall_arrayref succeeded.
2763             if (defined $r->{receive} && $r->{receive} =~ /^\d+$/) {
2764                 # Receive string specifies an exact number of rows
2765                 if ( $rows ne $r->{receive} ) {
2766                     ld_log( _message('WRN1704', $r->{receive}, $rows, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2767                     die;
2768                 }
2769             }
2770         }
2771     };
2772     alarm 0;
2773     sigaction(SIGALRM, $oldaction);
2774     if ($EVAL_ERROR) {
2775         if ($EVAL_ERROR eq "Connection timeout\n") {
2776             ld_log( _message('WRN1705', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2777         }
2778         return $SERVICE_DOWN;
2779     }
2780
2781     ld_log( _message('WRN0209', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2782     return $SERVICE_UP;
2783 }
2784
2785 # check_connect
2786 # Connect service health check.
2787 # Just connect port and close.
2788 sub check_connect {
2789     my ($v, $r) = @_;
2790     my $status = get_status([[$v, $r]]);
2791
2792     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2793
2794     ld_debug(2, "Checking connect: real server=$r->{server}{ip}:$port");
2795
2796     my $sock = ld_open_socket( $r->{server}{ip}, $port, $v->{protocol}, $v->{checktimeout} );
2797     if (!defined $sock) {
2798         ld_log( _message('WRN3201', $ERRNO, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2799
2800         return $SERVICE_DOWN;
2801     }
2802     close($sock);
2803
2804     ld_debug(3, "Connected to: (port $port)");
2805
2806     ld_log( _message('WRN0210', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2807     return $SERVICE_UP;
2808 }
2809
2810 # check_sip
2811 # SIP service health check.
2812 # Send SIP OPTIONS request and check 200 response
2813 sub check_sip {
2814     my ($v, $r) = @_;
2815     my $status = get_status([[$v, $r]]);
2816
2817     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
2818
2819     ld_debug(2, "Checking sip server=$r->{server}{ip} port=$port");
2820
2821     if ( !defined $v->{login} ) {
2822         ld_log( _message('WRN1801', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2823         return $SERVICE_DOWN;
2824     }
2825
2826     my $sock = ld_open_socket( $r->{server}{ip}, $port, $v->{protocol}, $v->{negotiatetimeout} );
2827     if (!defined $sock) {
2828         ld_log( _message('WRN1802', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2829         return $SERVICE_DOWN;
2830     }
2831
2832     my $sip_s_addr = $sock->sockhost;
2833     my $sip_s_port = $sock->sockport;
2834
2835     ld_debug(3, "Connected from $sip_s_addr:$sip_s_port to " . $r->{server} . ":$port");
2836
2837     my $id = $v->{login};
2838     my $request =
2839           "OPTIONS sip:$id SIP/2.0\r\n"
2840         . "Via: SIP/2.0/UDP $sip_s_addr:$sip_s_port;branch=z9hG4bKhjhs8ass877\r\n"
2841         . "Max-Forwards: 70\r\n"
2842         . "To: <sip:$id>\r\n"
2843         . "From: <sip:$id>;tag=1928301774\r\n"
2844         . "Call-ID: a84b4c76e66710\r\n"
2845         . "CSeq: 63104 OPTIONS\r\n"
2846         . "Contact: <sip:$id>\r\n"
2847         . "Accept: application/sdp\r\n"
2848         . "Content-Length: 0\r\n"
2849         . "\r\n";
2850
2851     ld_debug(3, "Request:\n$request");
2852
2853     my $response;
2854     eval {
2855         local $SIG{__DIE__} = 'DEFAULT';
2856         local $SIG{ALRM   } = sub { die "Connection timeout\n"; };
2857         ld_debug(4, "Timeout is $v->{negotiatetimeout}");
2858         alarm $v->{negotiatetimeout};
2859
2860         print {$sock} $request;
2861         $response = <$sock>;
2862         close $sock;
2863         alarm 0;
2864
2865         ld_debug(3, "Response:\n$response");
2866
2867         if ( $response !~ m{^SIP/2\.0 200 OK} ) {
2868             ld_log( _message('WRN1803', $response, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2869             die;
2870         }
2871     };
2872     alarm 0;
2873     if ($EVAL_ERROR) {
2874         if ($EVAL_ERROR eq "Connection timeout\n") {
2875             ld_log( _message('WRN1804', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
2876         }
2877         return $SERVICE_DOWN;
2878     }
2879
2880     ld_log( _message('WRN0211', $response, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
2881     return $SERVICE_UP;
2882 }
2883
2884 # check_ftp
2885 # FTP service health check.
2886 # Login server and get file if 'request' specified, and check file include 'receive' string
2887 sub check_ftp {
2888     require Net::FTP;
2889     my ($v, $r) = @_;
2890     my $status = get_status([[$v, $r]]);
2891
2892     my $ip_port = get_ip_port($r, $v->{checkport});
2893
2894     if (is_ip6($r->{server}{ip}) ){
2895         ## IPv6 route
2896         ## use 'lftp' Command
2897         ## lftp
2898         ##   -e ' set net:max-retries 1;
2899         ##        set net:reconnect-interval-multiplier 1;
2900         ##        set cmd:fail-exit true;
2901         ##        set net:reconnect-interval-base 1;
2902         ##        ls;ls ;exit'
2903         ##   -u user,passwd ipv6addr >/dev/null 2>&1
2904
2905         my $ftp_command     = "lftp ";
2906         my $ftp_environment1 = "-e \"set net:max-retries 2;";
2907         my $ftp_environment2 = "set net:reconnect-interval-multiplier 1;";
2908         my $ftp_environment3 = "set cmd:fail-exit true;";
2909         my $ftp_environment4 = "set net:reconnect-interval-base $v->{negotiatetimeout};";
2910         my $ftp_environment5 = "ls;ls;exit\" ";
2911         my $ftp_parameter   = "-u $v->{login},$v->{passwd} $ip_port >/dev/null 2>&1";
2912         $ftp_command .= $ftp_environment1 . $ftp_environment2. $ftp_environment3. $ftp_environment4. $ftp_environment5. $ftp_parameter;
2913
2914 ## print "ftpCommand:". $ftp_command;
2915         if( system_wrapper( $ftp_command )) {
2916             ld_log( _message('WRN3101', $v->{checktimeout}, $r->{server}{ip}) ) if (!defined $status || $status eq $SERVICE_UP);
2917             return $SERVICE_DOWN;
2918         }
2919         return $SERVICE_UP ;
2920     }
2921     ## IPv4 route
2922
2923     ld_debug(2, "Checking ftp server=$ip_port");
2924     my $debug_flag = $DEBUG_LEVEL ? 1 : 0;
2925
2926     if ( !defined $v->{login} || !defined $v->{passwd} || $v->{login} eq q{} ) {
2927         ld_log( _message('WRN1901', $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2928         return $SERVICE_DOWN;
2929     }
2930
2931     my $ftp = Net::FTP->new(
2932             $ip_port,
2933             Timeout => $v->{negotiatetimeout},
2934             Passive => 1,
2935             Debug   => $debug_flag,
2936          );
2937     if (!defined $ftp) {
2938         ld_log( _message('WRN1902', $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2939         return $SERVICE_DOWN;
2940     }
2941     if ( !$ftp->login( $v->{login}, $v->{passwd} ) ) {
2942         ld_log( _message('WRN1903', $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2943         $ftp->quit();
2944         return $SERVICE_DOWN;
2945     }
2946     if ( !$ftp->cwd('/') ) {
2947         ld_log( _message('WRN1904', $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2948         $ftp->quit();
2949         return $SERVICE_DOWN;
2950     }
2951     if ( $r->{request} ) {
2952         my $fail_flag = 0;
2953         eval {
2954             local $SIG{__DIE__} = 'DEFAULT';
2955             local $SIG{ALRM   } = sub { die "Connection timeout\n"; };
2956             alarm $v->{negotiatetimeout};
2957
2958             open my $tmp, '+>', undef;
2959             $ftp->binary();
2960             if ( !$ftp->get( $r->{request}, *$tmp ) ) {
2961                 alarm 0;
2962                 ld_log( _message('WRN1905', $r->{request}, $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2963                 close $tmp;
2964                 $ftp->quit();
2965                 $fail_flag = 1;
2966             }
2967             elsif ( $r->{receive} ) {
2968                 seek $tmp, 0, 0;
2969                 local $/;
2970                 my $memory = <$tmp>;
2971                 close $tmp;
2972                 if ($memory !~ /$r->{receive}/) {
2973                     alarm 0;
2974                     $ftp->quit();
2975                     ld_log( _message('WRN1906', $r->{receive}, $r->{request}, $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2976                     $fail_flag = 1;
2977                 }
2978             }
2979         };
2980         alarm 0;
2981         if ($EVAL_ERROR) {
2982             $ftp->quit();
2983             my $error_message = $EVAL_ERROR;
2984             $error_message =~ s/[\r\n]//g;
2985             if ($error_message eq 'Connection timeout') {
2986                 ld_log( _message('WRN1908', $v->{negotiatetimeout}, $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2987             }
2988             else {
2989                 ld_log( _message('WRN1907', $error_message, $ip_port) ) if (!defined $status || $status eq $SERVICE_UP);
2990             }
2991             return $SERVICE_DOWN;
2992         }
2993         if ($fail_flag) {
2994             $ftp->quit();
2995             return $SERVICE_DOWN;
2996         }
2997     }
2998     $ftp->quit();
2999
3000     ld_log( _message('WRN0212', $ip_port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
3001     return $SERVICE_UP;
3002 }
3003
3004 # check_dns
3005 # DNS service health check.
3006 # Connect server and search 'request' A or PTR record and check result include 'response' string
3007 sub check_dns {
3008     my ($v, $r) = @_;
3009     my $status = get_status([[$v, $r]]);
3010
3011     my $port = defined $v->{checkport} ? $v->{checkport} : $r->{server}{port};
3012
3013     {
3014         # Net::DNS makes ungaurded calls to eval
3015         # which throw a fatal exception if they fail
3016         local $SIG{__DIE__} = 'DEFAULT';
3017         require Net::DNS;
3018     }
3019     my $res = Net::DNS::Resolver->new();
3020
3021     if ($DEBUG_LEVEL) {
3022         $res->debug(1);
3023     }
3024
3025     if ( !defined $r->{request} || $r->{request} eq q{} || !defined $r->{receive} || $r->{receive} eq q{} ) {
3026         ld_log( _message('WRN2001', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
3027         return $SERVICE_DOWN;
3028     }
3029     ld_debug( 2, qq(Checking dns: request="$r->{request}" receive="$r->{receive}"\n) );
3030
3031     my $packet;
3032     eval {
3033         local $SIG{__DIE__} = 'DEFAULT';
3034         local $SIG{ALRM   } = sub { die "Connection timeout\n"; };
3035         alarm $v->{negotiatetimeout};
3036         $res->nameservers( $r->{server}{ip} );
3037         $res->port($port);
3038         $packet = $res->search( $r->{request} );
3039         alarm 0;
3040     };
3041     alarm 0;
3042     if ($EVAL_ERROR) {
3043         if ($EVAL_ERROR eq "Connection timeout\n") {
3044             ld_log( _message('WRN2002', $v->{negotiatetimeout}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
3045         }
3046         else {
3047             ld_log( _message('WRN2003', $EVAL_ERROR, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
3048         }
3049         return $SERVICE_DOWN;
3050     }
3051     if (!$packet) {
3052         ld_log( _message('WRN2004', $r->{request}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
3053         return $SERVICE_DOWN;
3054     }
3055
3056     my $match = 0;
3057     for my $rr ($packet->answer) {
3058         if (   ( $rr->type eq 'A'   && $rr->address  eq $r->{receive} )
3059             || ( $rr->type eq 'PTR' && $rr->ptrdname eq $r->{receive} ) ) {
3060             $match = 1;
3061             last;
3062         }
3063     }
3064     if (!$match) {
3065         ld_log( _message('WRN2005', $r->{receive}, $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_UP);
3066         return $SERVICE_DOWN;
3067     }
3068
3069     ld_log( _message('WRN0213', $r->{server}{ip}, $port) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
3070     return $SERVICE_UP;
3071 }
3072
3073 # check_ping
3074 # ICMP ping service health check.
3075 # Ping server and check response.
3076 sub check_ping {
3077     require Net::Ping;
3078     my ($v, $r) = @_;
3079     my $status = get_status([[$v, $r]]);
3080
3081     ld_debug( 2, qq(Checking ping: host="$r->{server}{ip}" checktimeout="$v->{checktimeout}"\n) );
3082
3083     if ( is_ip( $r->{server}{ip})) {
3084         ## IPv4 PingCheck
3085
3086         my $p = Net::Ping->new('icmp', 1);
3087         if ( !$p->ping( $r->{server}{ip}, $v->{checktimeout} ) ) {
3088             ld_log( _message('WRN3101', $v->{checktimeout}, $r->{server}{ip}) ) if (!defined $status || $status eq $SERVICE_UP);
3089             return $SERVICE_DOWN;
3090         }
3091     }
3092     else {
3093     ## IPv6 PingCheck
3094         my $command
3095             = sprintf "ping6 %s -c %d > /dev/null 2>&1",
3096                                      $r->{server}{ip},
3097                                      $v->{checktimeout};
3098
3099         if( system_wrapper( $command )) {
3100             ld_log( _message('WRN3101', $v->{checktimeout}, $r->{server}{ip}) ) if (!defined $status || $status eq $SERVICE_UP);
3101             return $SERVICE_DOWN;
3102         }
3103     }
3104
3105     ld_log( _message('WRN0214', $r->{server}{ip}) ) if (!defined $status || $status eq $SERVICE_DOWN || $r->{fail_counts} > 0);
3106     return $SERVICE_UP;
3107 }
3108
3109 # check_none
3110 # Dummy function to check service if service type is none.
3111 # Just activates the real server
3112 sub check_none {
3113     my ($v, $r) = @_;
3114     ld_debug(2, "Checking none");
3115     return $SERVICE_UP;
3116 }
3117
3118 # check_off
3119 # Check nothing and always return $SERVICE_DOWN
3120 sub check_off {
3121     my ($v, $r) = @_;
3122     return $SERVICE_DOWN;
3123 }
3124
3125 # check_on
3126 # Check nothing and always return $SERVICE_UP
3127 sub check_on {
3128     my ($v, $r) = @_;
3129     return $SERVICE_UP;
3130 }
3131
3132 # service_set
3133 # Used to bring up and down real servers.
3134 # This is the function you should call if you want to bring a real
3135 # server up or down.
3136 # This function is safe to call regrdless of the current state of a
3137 # real server.
3138 # Do _not_ call _service_up or _service_down directly.
3139 # pre: v_r_list: virtual and real pair list
3140 #                [ [$v, $r], [$v, $r] ... ]
3141 #      state: up or down
3142 #             up to bring the real service up
3143 #             down to bring the real service up
3144 # post: The real server is brough up or down for each virtual service
3145 #       it belongs to.
3146 # return: none
3147 sub service_set {
3148     my ($v_r_list, $state) = @_;
3149
3150     if (defined $state && $state eq 'up') {
3151         _service_up($v_r_list);
3152     }
3153     elsif (defined $state && $state eq 'down') {
3154         _service_down($v_r_list);
3155     }
3156 }
3157
3158 # _service_up
3159 # Bring a real service up if it is down
3160 # Should be called by service_set only
3161 # I.e. If you want to change the state of a real server call service_set.
3162 #      If you call this function directly then l7directord will lose track
3163 #      of the state of real servers.
3164 # pre: v_r_list: virtual and real pair list
3165 #                [ [$v, $r], [$v, $r] ... ]
3166 # post: real service is taken up from the respective virtual service
3167 #       if it is inactive
3168 # return: none
3169 sub _service_up {
3170     my $v_r_list = shift;
3171     if ( !_status_up($v_r_list) ) {
3172         return;
3173     }
3174
3175     for my $v_r_pair (@$v_r_list) {
3176         my ($v, $r) = @$v_r_pair;
3177         _restore_service($v, $r, 'real');
3178         fallback_off($v);
3179     }
3180 }
3181
3182 # _service_down
3183 # Bring a real service down if it is up
3184 # Should be called by service_set only
3185 # I.e. if you want to change the state of a real server call service_set.
3186 #      If you call this function directly then l7directord will lose track
3187 #      of the state of real servers.
3188 # pre: v_r_list: virtual and real pair list
3189 #                [ [$v, $r], [$v, $r] ... ]
3190 # post: real service is taken down from the respective virtual service
3191 #       if it is active
3192 # return: none
3193 sub _service_down {
3194     my $v_r_list = shift;
3195     if ( !_status_down($v_r_list) ) {
3196         return;
3197     }
3198
3199     for my $v_r_pair (@$v_r_list) {
3200         my ($v, $r) = @$v_r_pair;
3201         _remove_service($v, $r, 'real');
3202         fallback_on($v);
3203     }
3204 }
3205
3206 # _status_up
3207 # Set the status of a server as up
3208 # Should only be called from _service_up or fallback_on
3209 sub _status_up {
3210     my ($v_r_list, $is_fallback) = @_;
3211     if (!defined $v_r_list) {
3212         return 0;
3213     }
3214
3215     if (!$is_fallback) {
3216         my $current_status = get_status($v_r_list);
3217         if (defined $current_status && $current_status eq $SERVICE_UP) {
3218             return 0;
3219         }
3220
3221         my $id = get_health_check_id_str( @{ $v_r_list->[0] } );
3222         if (!defined $id) {
3223             ld_log( _message('ERR0503') );
3224             return 0;
3225         }
3226         $HEALTH_CHECK{$id}{status} = $SERVICE_UP;
3227
3228         return 1;
3229     }
3230     else {
3231         my $current_service = ld_read_l7vsadm();
3232         if (!defined $current_service) {
3233             ld_log( _message('FTL0201') );
3234             return 0;
3235         }
3236         my $vid = get_virtual_id_str( $v_r_list->[0][0] );
3237         if ( exists $current_service->{$vid} ) {
3238             # no real server
3239             if ( !defined $current_service->{$vid} ) {
3240                 return 1;
3241             }
3242             my $weight = 0;
3243             # all real server's weight are zero.
3244             for my $real ( keys %{ $current_service->{$vid} } ) {
3245                 if ( 'other_virtual_option' eq $real ){
3246                     next;
3247                 }
3248                 # already added fallback server.
3249                 if ( $real eq get_ip_port( $v_r_list->[0][1] ) ) {
3250                     return 0;
3251                 }
3252                 $weight += $current_service->{$vid}{$real}{weight};
3253             }
3254             if ($weight == 0) {
3255                 return 1;
3256             }
3257         }
3258         return 0;
3259     }
3260 }
3261
3262 # _status_down
3263 # Set the status of a server as down
3264 # Should only be called from _service_down or _ld_stop
3265 sub _status_down {
3266     my ($v_r_list, $is_fallback) = (@_);
3267     if (!defined $v_r_list) {
3268         return 0;
3269     }
3270
3271     if (!$is_fallback) {
3272         my $current_status = get_status($v_r_list);
3273         if ($current_status && $current_status eq $SERVICE_DOWN) {
3274             return 0;
3275         }
3276
3277         my $id = get_health_check_id_str( @{ $v_r_list->[0] } );
3278         if (!defined $id) {
3279             ld_log( _message('ERR0503') );
3280             return 0;
3281         }
3282         $HEALTH_CHECK{$id}{status} = $SERVICE_DOWN;
3283
3284         return 1;
3285     }
3286     else {
3287         my $current_service = ld_read_l7vsadm();
3288         if (!defined $current_service) {
3289             ld_log( _message('FTL0201') );
3290             return 0;
3291         }
3292         my $vid = get_virtual_id_str( $v_r_list->[0][0] );
3293         if ( defined $current_service->{$vid} ) {
3294             my $weight = 0;
3295             my $fallback_exist = 0;
3296             # any real server has weight.
3297             for my $real ( keys %{ $current_service->{$vid} } ) {
3298                 if ( 'other_virtual_option' eq $real ){
3299                     next;
3300                 }
3301                 if ( $real eq get_ip_port( $v_r_list->[0][1] ) ) {
3302                     $fallback_exist = 1;
3303                 }
3304                 $weight += $current_service->{$vid}{$real}{weight};
3305             }
3306             if ($fallback_exist && $weight) {
3307                 return 1;
3308             }
3309         }
3310         return 0;
3311     }
3312 }
3313
3314 # get_status
3315 # Get health check server status
3316 # return $SERVICE_UP / $SERVICE_DOWN
3317 sub get_status {
3318     my $v_r_list = shift;
3319
3320     my $id = get_health_check_id_str( @{ $v_r_list->[0] } );
3321     if (!defined $id) {
3322         ld_log( _message('ERR0503') );
3323         return 0;
3324     }
3325     return $HEALTH_CHECK{$id}{status};
3326 }
3327
3328 # _remove_service
3329 # Remove a real server by either making it quiescent or deleteing it
3330 # Should be called by _service_down or fallback_off
3331 # I.e. If you want to change the state of a real server call service_set.
3332 #      If you call this function directly then l7directord will lose track
3333 #      of the state of real servers.
3334 # If the real server exists (which it should) make it quiescent or
3335 # delete it, depending on the global and per virtual service quiecent flag.
3336 # If it # doesn't exist, just leave it as it will be added by the
3337 # _service_up code as appropriate.
3338 # pre: v: reference to virtual service to with the real server belongs
3339 #      rservice: service to restore. Of the form server:port for tcp
3340 #      rforw: Forwarding mechanism of service. Should be only "-m"
3341 #    rforw is kept as it is, even though not used - NTT COMWARE
3342 #      tag: Tag to use for logging. Should be either "real" or "fallback"
3343 # post: real service is taken up from the respective virtual service
3344 #       if it is inactive
3345 # return: none
3346 sub _remove_service {
3347     my ($v, $r, $tag) = @_;
3348     if (!defined $v || !defined $r) {
3349         ld_log( _message('ERR0501') );
3350         return;
3351     }
3352
3353     my $vip_id = get_virtual_id_str($v);
3354     if (!defined $vip_id) {
3355         ld_log( _message('ERR0502') );
3356         return;
3357     }
3358     my $oldsrv = ld_read_l7vsadm();
3359     if (!defined $oldsrv) {
3360         ld_log( _message('FTL0201') );
3361         return;
3362     }
3363
3364     if ( !exists $oldsrv->{$vip_id} ) {
3365         ld_log( _message( 'ERR0208', get_ip_port($r), get_ip_port($v) ) );
3366         return;
3367     }
3368
3369     # quiescent check
3370     my $is_quiescent = 0;
3371     if (!defined $tag || $tag ne 'fallback') {
3372         if ( defined $v->{quiescent} && $v->{quiescent} ) {
3373             $is_quiescent = 1;
3374         }
3375     }
3376
3377     my $or = $oldsrv->{$vip_id}{ get_ip_port($r) };
3378     # already removed server
3379     if (!defined $or && !$is_quiescent) {
3380         my $module_key = $v->{module}{name} . q{ } . $v->{module}{key};
3381         ld_log( _message( 'ERR0210', get_ip_port($r), get_ip_port($v), $module_key ) );
3382         return;
3383     }
3384     # already quiescent server
3385     if ( defined $or && $is_quiescent && $or->{weight} == 0 &&
3386          $or->{option}{forward} eq $r->{option}{forward} ) {
3387         my $module_key = $v->{module}{name} . q{ } . $v->{module}{key};
3388         ld_log( _message( 'ERR0211', get_ip_port($r), get_ip_port($v), $module_key ) );
3389         return;
3390     }
3391
3392     if ($is_quiescent) {
3393         if (defined $or) {
3394             ld_edit_real($v, $r, 0);
3395         }
3396         else {
3397             ld_add_real($v, $r, 0);
3398         }
3399         if (!defined $tag || $tag eq 'real') {
3400             ld_log( _message( 'INF0303', get_ip_port($r) ) );
3401         }
3402         elsif ($tag eq 'fallback') {
3403             ld_log( _message( 'INF0304', get_ip_port($r) ) );
3404         }
3405     }
3406     else {
3407         ld_delete_real($v, $r);
3408         if (!defined $tag || $tag eq 'real') {
3409             ld_log( _message( 'INF0305', get_ip_port($r) ) );
3410         }
3411         elsif ($tag eq 'fallback') {
3412             ld_log( _message( 'INF0306', get_ip_port($r) ) );
3413         }
3414     }
3415
3416     if ( defined $v->{realdowncallback} && $r->{healthchecked} ) {
3417         system_wrapper( $v->{realdowncallback}, get_ip_port($r) );
3418         ld_log( _message( 'INF0501',  $v->{realdowncallback}, get_ip_port($r) ) );
3419     }
3420     $r->{healthchecked} = 1;
3421 }
3422
3423 # _restore_service
3424 # Make a retore a real server. The opposite of _quiescent_server.
3425 # Should be called by _service_up or fallback_on
3426 # I.e. If you want to change the state of a real server call service_set.
3427 #      If you call this function directly then l7directord will lose track
3428 #      of the state of real servers.
3429 # If the real server exists (which it should) make it quiescent. If it
3430 # doesn't exist, just leave it as it will be added by the _service_up code
3431 # as appropriate.
3432 # pre: v: reference to virtual service to with the real server belongs
3433 #      r: reference to real server to restore.
3434 #      tag: Tag to use for logging. Should be either "real" or "fallback"
3435 # post: real service is taken up from the respective virtual service
3436 #       if it is inactive
3437 # return: none
3438 sub _restore_service {
3439     my ($v, $r, $tag) = @_;
3440     if (!defined $v || !defined $r) {
3441         ld_log( _message('ERR0501') );
3442         return;
3443     }
3444
3445     my $vip_id = get_virtual_id_str($v);
3446     if (!defined $vip_id) {
3447         ld_log( _message('ERR0502') );
3448         return;
3449     }
3450     my $oldsrv = ld_read_l7vsadm();
3451     if (!defined $oldsrv) {
3452         ld_log( _message('FTL0201') );
3453         return;
3454     }
3455
3456     if ( !exists $oldsrv->{$vip_id} ) {
3457         ld_log( _message( 'ERR0207', get_ip_port($r), get_ip_port($v) ) );
3458         return;
3459     }
3460
3461     my $or = $oldsrv->{$vip_id}{ get_ip_port($r) };
3462     # already completely same server exist
3463     if ( defined $or &&
3464          $or->{weight} eq $r->{weight} &&
3465          $or->{option}{forward} eq $r->{option}{forward} ) {
3466         my $module_key = $v->{module}{name} . q{ } . $v->{module}{key};
3467         ld_log( _message( 'ERR0209', get_ip_port($r), get_ip_port($v), $module_key ) );
3468         return;
3469     }
3470
3471     if (defined $or) {
3472         ld_edit_real( $v, $r, $r->{weight} );
3473     }
3474     else {
3475         ld_add_real( $v, $r, $r->{weight} );
3476     }
3477
3478     if (!defined $tag || $tag eq 'real') {
3479         ld_log( _message( 'INF0301', get_ip_port($r) ) );
3480     }
3481     elsif ($tag eq 'fallback') {
3482         ld_log( _message( 'INF0302', get_ip_port($r) ) );
3483     }
3484
3485     if ( defined $v->{realrecovercallback} && $r->{healthchecked} ){
3486         system_wrapper( $v->{realrecovercallback}, get_ip_port($r) );
3487         ld_log( _message( 'INF0502',  $v->{realrecovercallback}, get_ip_port($r) ) );
3488     }
3489     $r->{healthchecked} = 1;
3490 }
3491
3492 # fallback_on
3493 # Turn on the fallback server for a virtual service if it is inactive
3494 # pre: v: virtual to turn fallback service on for
3495 # post: fallback server is turned on if it was inactive
3496 # return: none
3497 sub fallback_on {
3498     my $v = shift;
3499
3500     my $fallback = fallback_find($v);
3501     if (defined $fallback) {
3502         my $v_r_list = [ [ $v, $fallback->{tcp} ] ];
3503         if ( _status_up($v_r_list, 'fallback') ) {
3504             _restore_service($v, $fallback->{tcp}, 'fallback');
3505         }
3506     }
3507 }
3508
3509 # fallback_off
3510 # Turn off the fallback server for a virtual service if it is active
3511 # pre: v: virtual to turn fallback service off for
3512 # post: fallback server is turned off if it was active
3513 # return: none
3514 sub fallback_off {
3515     my $v = shift;
3516
3517     my $fallback = fallback_find($v);
3518     if (defined $fallback) {
3519         my $v_r_list = [ [ $v, $fallback->{tcp} ] ];
3520         if ( _status_down($v_r_list, 'fallback') ) {
3521             _remove_service($v, $fallback->{tcp}, 'fallback');
3522         }
3523     }
3524 }
3525
3526 # fallback_find
3527 # Determine the fallback for a virtual service
3528 # pre: v: reference to a virtual service
3529 # post: none
3530 # return: $v->{fallback} if defined
3531 #         else undef
3532 sub fallback_find {
3533     my $v = shift;
3534     if (!defined $v) {
3535         ld_log( _message('ERR0501') );
3536         return;
3537     }
3538     return $v->{fallback};
3539 }
3540
3541 # check_cfgfile
3542 # Check configfile change.
3543 # pre: none
3544 # post: check configfile size, and then check md5 sum
3545 # return: 1 if notice file change
3546 #         0 if not notice or not change
3547 sub check_cfgfile {
3548     if (!defined $CONFIG_FILE{path}) {
3549         ld_log( _message('FTL0102') );
3550         return 0;
3551     }
3552
3553     my $mtime = (stat $CONFIG_FILE{path})[9];
3554     if (!defined $mtime) {
3555         ld_log( _message( 'ERR0410', $CONFIG_FILE{path} ) );
3556         return 0;
3557     }
3558
3559     if ( defined $CONFIG_FILE{stattime} && $mtime == $CONFIG_FILE{stattime} ) {
3560         # file mtime is not change
3561         return 0;
3562     }
3563     $CONFIG_FILE{stattime} = $mtime;
3564
3565     my $digest = undef;;
3566     eval {
3567         require Digest::MD5;
3568
3569         my $ctx = Digest::MD5->new();
3570         open my $config, '<', $CONFIG_FILE{path};
3571         $ctx->addfile($config);
3572         $digest = $ctx->hexdigest;
3573         close $config;
3574     };
3575     if ($EVAL_ERROR) {
3576         ld_log( _message( 'ERR0407', $CONFIG_FILE{path} ) );
3577         return 0;
3578     }
3579
3580     if (defined $CONFIG_FILE{checksum} && $digest &&
3581                 $CONFIG_FILE{checksum} ne $digest ) {
3582         ld_log( _message('WRN0101', $CONFIG_FILE{path}) );
3583         $CONFIG_FILE{checksum} = $digest;
3584
3585         if ( defined $CONFIG{callback} && -x $CONFIG{callback} ) {
3586             system_wrapper( $CONFIG{callback} . q{ } . $CONFIG_FILE{path} );
3587             ld_log( _message( 'INF0503',  $CONFIG{callback}, $CONFIG_FILE{path} ) );
3588         }
3589
3590         if ( $CONFIG{autoreload} ) {
3591             ld_log( _message('WRN0102') );
3592             return 1;
3593         }
3594         else {
3595             ld_log( _message('WRN0103') );
3596             return 0;
3597         }
3598     }
3599
3600     $CONFIG_FILE{checksum} = $digest;
3601     return 0;
3602 }
3603
3604 # ld_openlog
3605 # Open logger
3606 # make log rotation work
3607 # pre: log setting
3608 # post: If logger is a file, it opened and closed again as a test
3609 #       If logger is syslog, it is opened so it can be used without
3610 #       needing to be opened again.
3611 #       Otherwiese, nothing is done.
3612 # return: 0 on success
3613 #         1 on error
3614 sub ld_openlog {
3615     my $log_config = shift;
3616     if (!defined $log_config) {
3617         ld_log( _message('ERR0501') );
3618         return 1;
3619     }
3620
3621     if ( $DEBUG_LEVEL > 0 or $CONFIG{supervised} ) {
3622         # Instantly do nothing
3623         return 0;
3624     }
3625
3626     if ( $log_config =~ m{^/}) {
3627         # Open and close the file as a test.
3628         # We open the file each time we want to log to it
3629         eval {
3630             open my $log_file, ">>", $log_config;
3631             close $log_file;
3632         };
3633         if ($EVAL_ERROR) {
3634             ld_log( _message('ERR0118', $log_config) );
3635             return 1;
3636         }
3637     }
3638     else {
3639         # Assume $log_config is a logfacility, log to syslog
3640         setlogsock("unix");
3641         openlog("l7directord", "pid", $log_config);
3642         # FIXME "closelog" not found
3643     }
3644
3645     $PROC_STAT{log_opened} = 1;
3646     return 0;
3647 }
3648
3649 # ld_log
3650 # Log a message.
3651 # pre: message: Message to write
3652 # post: message and timetsamp is written to loged
3653 #       If logger is a file, it is opened and closed again as a
3654 #       primative means to make log rotation work
3655 # return: 0 on success
3656 #         1 on error
3657 sub ld_log {
3658     my $message = shift;
3659     if (!defined $message) {
3660         ld_log( _message('ERR0501') );
3661         return 1;
3662     }
3663
3664     ld_debug(2, $message);
3665     chomp $message;
3666
3667     if ( !$CONFIG{supervised} && !$PROC_STAT{log_opened} ) {
3668         return 1;
3669     }
3670
3671     my $now = localtime();
3672     my $line_header = sprintf "[%s|%d] ", $now, $PROC_STAT{pid};
3673     $message =~ s/^/$line_header/mg;
3674
3675     if ( $CONFIG{supervised} ) {
3676         print {*STDOUT} $message . "\n";
3677     }
3678     elsif ( $CONFIG{logfile} =~ m{^/} ) {
3679         eval {
3680             open my $log_file, '>>', $CONFIG{logfile};
3681             flock $log_file, 2; # LOCK_EX
3682             print {$log_file} $message . "\n";
3683             close $log_file;
3684         };
3685         if ($EVAL_ERROR) {
3686             print {*STDERR} _message_only( 'FTL0103', $CONFIG{logfile}, $message ) . "\n";
3687             return 1;
3688         }
3689     }
3690     else {
3691         # Assume LOGFILE is a logfacility, log to syslog
3692         syslog('info', $message);
3693     }
3694     return 0;
3695 }
3696
3697 # ld_debug
3698 # Log a message to a STDOUT.
3699 # pre: priority: priority of message
3700 #      message: Message to write
3701 # post: message is written to STDOUT if $DEBUG_LEVEL >= priority
3702 # return: none
3703 sub ld_debug {
3704     my ($priority, $message) = @_;
3705
3706     if (defined $priority && $priority =~ /^\d+$/ &&
3707         defined $message  && $DEBUG_LEVEL >= $priority) {
3708         chomp $message;
3709         $message =~ s/^/DEBUG[$priority]: /mg;
3710         print {*STDERR} $message . "\n";
3711     }
3712 }
3713
3714 # command_wrapper
3715 # Wrapper around command(qx) to get output
3716 # pre: command to execute
3717 # post: execute command and if it returns non-zero a failure
3718 #       message is logged
3719 # return: return value of command, and output
3720 sub command_wrapper {
3721     my $command = shift;
3722
3723     if ($DEBUG_LEVEL > 2) {
3724         ld_log( _message( 'INF0506', $command) );
3725     }
3726
3727     $command =~ s/([{}\\])/\\$1/g;
3728     my $output = qx($command);
3729     if ($CHILD_ERROR != 0) {
3730         ld_log( _message('ERR0303', $command, $CHILD_ERROR) );
3731     }
3732     return ($CHILD_ERROR, $output);
3733 }
3734
3735 # system_wrapper
3736 # Wrapper around system() to log errors
3737 # pre: LIST: arguments to pass to system()
3738 # post: system() is called and if it returns non-zero a failure
3739 #       message is logged
3740 # return: return value of system()
3741 sub system_wrapper {
3742     my @args = @_;
3743
3744     if ($DEBUG_LEVEL > 2) {
3745         ld_log( _message( 'INF0504', join(q{ }, @args) ) );
3746     }
3747     my $status = system(@args);
3748     if ($DEBUG_LEVEL > 2) {
3749         if ($status != 0) {
3750             ld_log( _message('ERR0301', join(q{ }, @args), $status) );
3751         }
3752     }
3753     return $status;
3754 }
3755
3756 # exec_wrapper
3757 # Wrapper around exec() to log errors
3758 # pre: LIST: arguments to pass to exec()
3759 # post: exec() is called and if it returns non-zero a failure
3760 #       message is logged
3761 # return: return value of exec() on failure
3762 #         does not return on success
3763 sub exec_wrapper {
3764     my @args = @_;
3765
3766     if ($DEBUG_LEVEL > 2) {
3767         ld_log( _message( 'INF0505', join(q{ }, @args) ) );
3768     }
3769     my $status = exec(@args);
3770     if (!$status) {
3771         ld_log( _message('ERR0302', join(q{ }, @args), $status) );
3772     }
3773     return $status;
3774 }
3775
3776 # ld_rm_file
3777 # Remove a file, symink, or anything that isn't a directory
3778 # and exists
3779 # pre: filename: file to delete
3780 # post: If filename does not exist or is a directory an
3781 #       error state is reached
3782 #       Else filename is delete
3783 #       If $DEBUG_LEVEL >=2 errors are logged
3784 # return:  0 on success
3785 #         -1 on error
3786 sub ld_rm_file {
3787     my $filename = shift;
3788     if (!defined $filename) {
3789         ld_log( _message('ERR0411') );
3790         return -1;
3791     }
3792     if (-d $filename) {
3793         ld_log( _message('ERR0401', $filename) );
3794         return -1;
3795     }
3796     if (!-e $filename) {
3797         ld_log( _message('ERR0402', $filename) );
3798         return -1;
3799     }
3800     my $status = unlink $filename;
3801     if ($status != 1) {
3802         ld_log( _message('ERR0403', $filename, $ERRNO) );
3803         return -1;
3804     }
3805     return 0;
3806 }
3807
3808 # is_octet
3809 # See if a number is an octet, that is >=0 and <=255
3810 # pre: alleged_octet: the octect to test
3811 # post: alleged_octect is checked to see if it is valid
3812 # return: 1 if the alleged_octet is an octet
3813 #         0 otherwise
3814 sub is_octet {
3815     my $alleged_octet = shift;
3816     if (!defined $alleged_octet || $alleged_octet !~ /^\d+$/ || $alleged_octet > 255) {
3817         ld_log( _message('ERR0501') );
3818         return 0;
3819     }
3820     return 1;
3821 }
3822
3823 # is_ip
3824 # Check that a given string is an IP address
3825 # pre: alleged_ip: string representing ip address
3826 # post: alleged_ip is checked to see if it is valid
3827 # return: 1 if alleged_ip is a valid ip address
3828 #         0 otherwise
3829 sub is_ip {
3830     my $alleged_ip = shift;
3831
3832     # If we don't have four, . delimited numbers then we have no hope
3833     if (!defined $alleged_ip || $alleged_ip !~ m/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/) {
3834 ##        ld_log( _message('ERR0501') );
3835         return 0;
3836     }
3837
3838     # Each octet must be >=0 and <=255
3839     is_octet($1) or return 0;
3840     is_octet($2) or return 0;
3841     is_octet($3) or return 0;
3842     is_octet($4) or return 0;
3843
3844     return 1;
3845 }
3846
3847 # is_ip6
3848 # Check that a given string is an IPv6 address
3849 # pre: alleged_ip6: string representing ip address
3850 # post: alleged_ip6 is checked to see if it is valid
3851 # return: 1 if alleged_ip is a valid ipv6 address
3852 #         0 otherwise
3853 sub is_ip6 {
3854     my $alleged_ip = shift;
3855     my @return_array = (0, undef);
3856
3857     if (!defined $alleged_ip ) {
3858         ld_log( _message('ERR0501') );
3859         return 0;
3860     }
3861
3862     ## Change IPv6 Address
3863     $alleged_ip =~ s/[\[\]]//g;
3864     ## get LinkLocal
3865     my ($work, $link_local) = split /%/, $alleged_ip;
3866     my @address;
3867     if ( $alleged_ip =~ /::/ ){
3868         my ($adr_a, $adr_b) = split /::/, $alleged_ip;
3869         my @adr_a           = split /:/ , $adr_a;
3870         my @adr_b           = split /:/ , $adr_b;
3871         for(scalar @adr_a .. 7 - scalar @adr_b){
3872             push @adr_a,0;
3873         }
3874         @address = (@adr_a, @adr_b);
3875     }
3876     else {
3877         @address = split /:/, $alleged_ip;
3878     }
3879     $alleged_ip  = join ":", @address;
3880     if ( defined $link_local ){
3881         $alleged_ip .= '%' . $link_local;
3882     }
3883     if (!defined $alleged_ip ||
3884             $alleged_ip !~ m/^([0-9a-fA-F]{1,4}):
3885                               ([0-9a-fA-F]{1,4}):
3886                               ([0-9a-fA-F]{1,4}):
3887                               ([0-9a-fA-F]{1,4}):
3888                               ([0-9a-fA-F]{1,4}):
3889                               ([0-9a-fA-F]{1,4}):
3890                               ([0-9a-fA-F]{1,4}):
3891                               ([0-9a-fA-F]{1,4})(%.+)?$/x) {
3892         return 0;
3893     }
3894     @return_array = (1, @address);
3895     return @return_array;
3896 }
3897
3898
3899 # ip_to_int
3900 # Turn an IP address given as a dotted quad into an integer
3901 # pre: ip_address: string representing IP address
3902 # post: post ip_address is converted to an integer
3903 # return: -1 if an error occurs
3904 #         integer representation of IP address otherwise
3905 sub ip_to_int {
3906     my $ip_address = shift;
3907     my $ip_version = 'ipv4';
3908     my $result = undef;
3909     my $result2 = undef;
3910     my @return_array = (undef, -1);
3911
3912
3913     if ( is_ip($ip_address) ) {
3914         my ($oct1, $oct2, $oct3, $oct4)
3915             = $ip_address =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)$/;
3916         $result = ($oct1 << 24) + ($oct2 << 16) + ($oct3 << 8) + $oct4;
3917     }
3918     else {
3919         my ( $ret, @address ) = is_ip6($ip_address);
3920         if ( $ret == 1 ) {
3921             my ( $hex1, $hex2, $hex3, $hex4, $hex5, $hex6, $hex7, $hex8, $linklocal) = @address;
3922             $result  = (hex($hex5) << 48)  + (hex($hex6) << 32) + (hex($hex7) << 16)  + hex($hex8);
3923             $result2 = (hex($hex1) << 48)  + (hex($hex2) << 32) + (hex($hex3) << 16)  + hex($hex4);
3924             $ip_version = 'ipv6';
3925         }
3926         else {
3927             return @return_array;
3928         }
3929     }
3930     @return_array = ($ip_version, $result, $result2);
3931     return @return_array;
3932 }
3933
3934 # int_to_ip
3935 # Turn an IP address given as an integer into a dotted quad
3936 # pre: ip_address: integer representation of IP address
3937 # post: Decimal is converted to a dotted quad
3938 # return: string representing IP address
3939 sub int_to_ip {
3940     my ($ip_version, $ip_address,$ip_address2) = @_;
3941     if (!defined $ip_address || $ip_address !~ /^\d+$/ ) {
3942      ##|| !defined $ip_version || $ip_version !~ /ipv[46]/ ) {
3943         ld_log( _message('ERR0501') );
3944         return;
3945     }
3946
3947     my $result = undef;
3948     if ($ip_version eq 'ipv6') {
3949     ## IPv6 Address Change
3950         $result = sprintf "%0x:%0x:%0x:%0x:%0x:%0x:%0x:%0x",
3951                          ($ip_address2 >>  48) & 0xffff,
3952                          ($ip_address2 >>  32) & 0xffff,
3953                          ($ip_address2 >>  16) & 0xffff,
3954                          ($ip_address2   ) & 0xffff,
3955                          ($ip_address >>  48) & 0xffff,
3956                          ($ip_address >>  32) & 0xffff,
3957                          ($ip_address >>  16) & 0xffff,
3958                          ($ip_address       ) & 0xffff;
3959     }
3960     else {
3961     ## IPv4 Address Change
3962         $result = sprintf "%d.%d.%d.%d",
3963                          ($ip_address >> 24) & 0xff,
3964                          ($ip_address >> 16) & 0xff,
3965                          ($ip_address >> 8 ) & 0xff,
3966                          ($ip_address      ) & 0xff;
3967     }
3968     return $result;
3969 }
3970
3971 # get_ip_port
3972 # Get the service for a virtual or a real
3973 # pre: host: virtual or real to get the service for
3974 # post: none
3975 # return: ip_address:port
3976 sub get_ip_port {
3977     my ($host, $checkport) = @_;
3978     my $server = defined $host && defined $host->{server} && defined $host->{server}{ip}
3979                     ? $host->{server}{ip  } : q{};
3980     if (is_ip6($server)) {
3981         $server = sprintf "[%s]" , $server;
3982     }
3983     my $port   = defined $checkport ? $checkport
3984                : defined $host && defined $host->{server} && defined $host->{server}{port}
3985                     ? $host->{server}{port} : q{};
3986
3987     my $ip_port = $server ne q{} && $port ne q{} ? "$server:$port" : q{};
3988     return $ip_port;
3989 }
3990
3991 # get_health_check_id_str
3992 # Get an id string for a health check process
3993 # pre: r: Real service.
3994 #      v: Virtual service
3995 # post: none
3996 # return: Id string for the health check process
3997 sub get_health_check_id_str {
3998     my ($v, $r) = @_;
3999     if ( !defined $v || !defined $r || !defined $r->{server} ) {
4000         ld_log( _message('ERR0501') );
4001         return;
4002     }
4003
4004     my $ip   = defined $r->{server}{ip  } ? $r->{server}{ip  } : q{};
4005     my $port = defined $v->{checkport   } ? $v->{checkport   } :
4006                defined $r->{server}{port} ? $r->{server}{port} : q{};
4007     my $checktype    = defined $v->{checktype   } ? $v->{checktype   } : q{};
4008     my $service      = defined $v->{service     } ? $v->{service     } : q{};
4009     my $protocol     = defined $v->{protocol    } ? $v->{protocol    } : q{};
4010     my $num_connects = defined $v->{num_connects} ? $v->{num_connects} : q{};
4011     my $request      = defined $r->{request     } ? $r->{request     } : q{};
4012     my $receive      = defined $r->{receive     } ? $r->{receive     } : q{};
4013     my $httpmethod   = defined $v->{httpmethod  } ? $v->{httpmethod  } : q{};
4014     my $virtualhost  = defined $v->{virtualhost } ? $v->{virtualhost } : q{};
4015     my $login        = defined $v->{login       } ? $v->{login       } : q{};
4016     my $password     = defined $v->{passwd      } ? $v->{passwd      } : q{};
4017     my $database     = defined $v->{database    } ? $v->{database    } : q{};
4018     ## fumei
4019     my $customcheck  = defined $v->{customcheck } ? $v->{customcheck } : q{};
4020     my $checkinterval    = defined $v->{checkinterval    } ? $v->{checkinterval    } : q{};
4021     my $checkcount       = defined $v->{checkcount       } ? $v->{checkcount       } : q{};
4022     my $checktimeout     = defined $v->{checktimeout     } ? $v->{checktimeout     } : q{};
4023     my $negotiatetimeout = defined $v->{negotiatetimeout } ? $v->{negotiatetimeout } : q{};
4024     my $retryinterval    = defined $v->{retryinterval    } ? $v->{retryinterval    } : q{};
4025
4026     # FIXME SHOULD change separator. (request, receive, login, passwd ,database may include ':')
4027     my $id = "$ip:$port:$checktype:$service:$protocol:$num_connects:$request:$receive:" .
4028              "$httpmethod:$virtualhost:$login:$password:$database:$customcheck:" .
4029              "$checkinterval:$checkcount:$checktimeout:$negotiatetimeout:$retryinterval";
4030
4031     return $id;
4032 }
4033
4034 # get_virtual_id_str
4035 # Get an id string for a virtual service
4036 # pre: v: Virtual service
4037 # post: none
4038 # return: Id string for the virtual service
4039 sub get_virtual_id_str {
4040     my $v = shift;
4041     if ( !defined $v || !defined $v->{module} ) {
4042         ld_log( _message('ERR0501') );
4043         return;
4044     }
4045
4046     my $ip_port     = get_ip_port($v);
4047     my $protocol    = defined $v->{protocol    } ? $v->{protocol    } : q{};
4048     my $module_name = defined $v->{module}{name} ? $v->{module}{name} : q{};
4049     my $module_key  = defined $v->{module}{key } ? $v->{module}{key } : q{};
4050
4051     my $id = "$protocol:$ip_port:$module_name $module_key";
4052     $id =~ s/ +$//;
4053
4054     return $id;
4055     # [cf] id = "tcp:127.0.0.1:80:cinsert --cookie-name 'monkey'"
4056 }
4057
4058 # get_forward_flag
4059 # Get the l7vsadm flag corresponging to a forwarding mechanism
4060 # pre: forward: Name of forwarding mechanism. (masq or tproxy)
4061 # post: none
4062 # return: l7vsadm flag corresponding to the forwading mechanism
4063 #         " " if $forward is unknown
4064 sub get_forward_flag {
4065     my $forward = shift;
4066
4067     if (defined $forward && $forward =~ /^masq$/i) {
4068         return '--masq';
4069     }
4070     elsif (defined $forward && $forward =~ /^tproxy$/i) {
4071         return '--tproxy';
4072     }
4073     return q{};
4074 }
4075
4076 # ld_exit
4077 # Exit and log a message
4078 # pre: exit_status: Integer exit status to exit with
4079 #                   0 wiil be used if parameter is omitted
4080 #      message: Message to log when exiting. May be omitted
4081 # post: If exit_status is non-zero or $DEBUG_LEVEL>2 then
4082 #       message logged.
4083 #       Programme exits with exit_status
4084 # return: does not return
4085 sub ld_exit {
4086     my ($exit_status, $message) = @_;
4087     if (defined $exit_status && defined $message) {
4088         ld_log( _message('INF0006', $exit_status, $message) );
4089     }
4090     exit $exit_status;
4091 }
4092
4093 # ld_open_socket
4094 # Open a socket connection
4095 # pre: remote: IP address as a dotted quad of remote host to connect to
4096 #      port: port to connect to
4097 #      protocol: Prococol to use. Should be either "tcp" or "udp"
4098 # post: A Socket connection is opened to the remote host
4099 # return: Open socket
4100 sub ld_open_socket {
4101     require IO::Socket::INET6;
4102     my ($remote, $port, $protocol, $timeout) = @_;
4103     my $sock_handle = IO::Socket::INET6->new(
4104             PeerAddr => $remote,
4105             PeerPort => $port,
4106             Proto    => $protocol,
4107             Timeout  => $timeout,
4108         );
4109
4110     return $sock_handle;
4111 }
4112
4113 # daemon
4114 # Close and fork to become a daemon.
4115 #
4116 # Notes from unix programmer faq
4117 # http://www.landfield.com/faqs/unix-faq/programmer/faq/
4118 #
4119 # Almost none of this is necessary (or advisable) if your daemon is being
4120 # started by `inetd'.  In that case, stdin, stdout and stderr are all set up
4121 # for you to refer to the network connection, and the `fork()'s and session
4122 # manipulation should *not* be done (to avoid confusing `inetd').  Only the
4123 # `chdir()' step remains useful.
4124 sub ld_daemon {
4125     ld_daemon_become_child();
4126
4127     if (POSIX::setsid() < 0) {
4128         ld_exit( 7, _message_only('ERR0702') );
4129     }
4130
4131     ld_daemon_become_child();
4132
4133     if (chdir('/') < 0) {
4134         ld_exit( 8, _message_only('ERR0703') );
4135     }
4136
4137     close *STDIN;
4138     close *STDOUT;
4139     close *STDERR;
4140
4141     eval { open  *STDIN, '<', '/dev/null'; };
4142     ld_exit(9, _message_only('ERR0704') ) if ($EVAL_ERROR);
4143     eval { open *STDOUT, '>>', '/dev/console'; };
4144     ld_exit(10, _message_only('ERR0705') ) if ($EVAL_ERROR);
4145     eval { open *STDERR, '>>', '/dev/console'; };
4146     ld_exit(10, _message_only('ERR0705') ) if ($EVAL_ERROR);
4147 }
4148
4149 # ld_daemon_become_child
4150 # Fork, kill parent and return child process
4151 # pre: none
4152 # post: process forkes and parent exits
4153 #       All preocess exit with exit status -1 if an error occurs
4154 # return: parent: exits
4155 #         child: none  (this is the process that returns)
4156 sub ld_daemon_become_child {
4157     my $status = fork();
4158     $PROC_STAT{pid} = $PID;
4159
4160     if ($status < 0) {
4161         ld_exit( 6, _message_only('ERR0701', $ERRNO) );
4162     }
4163     if ($status > 0) {
4164         ld_exit( 0, _message_only('INF0005') );
4165     }
4166 }
4167
4168 # ld_gethostbyname
4169 # Wrapper to gethostbyname. Look up the/an IP address of a hostname
4170 # If an IP address is given is it returned
4171 # pre: name: Hostname of IP address to lookup
4172 # post: gethostbyname is called to find an IP address for $name
4173 #       This is converted to a string
4174 # return: IP address
4175 #         undef on error
4176 sub ld_gethostbyname {
4177     require IO::Socket::INET6;
4178     my $name = shift;
4179     $name = q{} if !defined $name;
4180     my $addrs = ( gethostbyname($name) )[4];
4181     if ( defined $addrs && $addrs ){
4182         return Socket::inet_ntoa($addrs);
4183     }
4184     else {
4185         $name =~ s/\[|\]//g;
4186         my $addrs = ( gethostbyname2($name, AF_INET6) )[4] or return;
4187         return inet_ntop(AF_INET6,$addrs);
4188     }
4189     return;
4190 }
4191
4192 # ld_getservbyname
4193 # Wraper for getservbyname. Look up the port for a service name
4194 # If a port is given it is returned.
4195 # pre: name: Port or Service name to look up
4196 # post: if $name is a number
4197 #         if 0<=$name<=65536 $name is returned
4198 #         else undef is returned
4199 #       else getservbyname is called to look up the port for the service
4200 # return: Port
4201 #         undef on error
4202 sub ld_getservbyname {
4203     my ($name, $protocol) = @_;
4204     $name     = q{} if !defined $name;
4205     $protocol = q{} if !defined $protocol;
4206
4207     if ($name =~ /^\d+$/) {
4208         if ($name > 65535) {
4209             return;
4210         }
4211         return $name;
4212     }
4213
4214     my $port = ( getservbyname($name, $protocol) )[2];
4215     return $port;
4216 }
4217
4218 # ld_gethostservbyname
4219 # Wraper for ld_gethostbyname and ld_getservbyname. Given a server of the
4220 # form ip_address|hostname:port|servicename return hash refs of ip_address and port
4221 # pre: hostserv: Servver of the form ip_address|hostname:port|servicename
4222 #      protocol: Protocol for service. Should be either "tcp" or "udp"
4223 # post: lookups performed as per ld_getservbyname and ld_gethostbyname
4224 # return: { ip => ip_address, port => port }
4225 #         undef on error
4226 sub ld_gethostservbyname {
4227     my ($hostserv, $protocol) = @_;
4228     my $ip   = undef;
4229     my $port = undef;
4230
4231     if (!defined $hostserv || $hostserv !~ /
4232             ^
4233             (\d+\.\d+\.\d+\.\d+|[a-z0-9.-]+) # host or ip
4234             :                                # colon
4235             (\d+|[a-z0-9-]+)                 # serv or port
4236             $
4237         /ix) {
4238         if ( !defined $hostserv || $hostserv !~ /
4239                  ^
4240              (\[[a-z0-9.-:%]+\]) # host or ip
4241                  :                           # colon
4242                  (\d+|[a-z0-9-]+)            # serv or port
4243                  $
4244              /ix) {
4245             return;
4246         }
4247         $ip   = $1;
4248         $port = $2;
4249         $ip   =~ s/\[|\]//g;
4250
4251     }
4252     else {
4253         $ip   = $1;
4254         $port = $2;
4255     }
4256
4257     $ip   = ld_gethostbyname($ip) or return;
4258     $port = ld_getservbyname($port, $protocol);
4259
4260     return if !defined $port;
4261
4262     return {ip => $ip, port => $port};
4263 }
4264
4265 # _message_only
4266 # Create message only.
4267 sub _message_only {
4268     my ($code, @message_args) = @_;
4269
4270     my $message_list = {
4271         # health check process exit
4272         FTL0001 => "health_check argument is invalid. Exit this monitor process with status: 1",
4273         FTL0002 => "health_check argument pair, virtual or real structure is invalid. Exit this monitor process with status: 2",
4274         FTL0003 => "Detected down management process (pid: %s). Exit this monitor process with status: 3",
4275         # file fatal error
4276         FTL0101 => "l7vsadm file `%s' is not found or cannot execute.",
4277         FTL0102 => "Config file is not defined. So cannot check configuration change.",
4278         FTL0103 => "Cannot open logfile `%s'. Log message: `%s'",
4279         # command fatal error
4280         FTL0201 => "Result of read from l7vsadm is not defined.",
4281
4282         # exit
4283         ERR0001 => "Initialization error: %s",
4284         ERR0002 => "Configuration error and exit.",
4285         # validation error
4286         ERR0101 => "Invalid value (set natural number) `%s'.",
4287         ERR0102 => "Invalid value (set `yes' or `no') `%s'.",
4288         ERR0103 => "Invalid value (set any word) `%s'.",
4289         ERR0104 => "Invalid value (set `custom', `connect', `negotiate', `ping', `off', `on' "
4290                  . "or positive number) `%s'.",
4291         ERR0105 => "Invalid schedule module (should be only lowercase letters (a-z)) `%s'.",
4292         ERR0106 => "Invalid value (set `http', `https', `ftp', `smtp', `pop', `imap', "
4293                  . "`ldap', `nntp', `dns', `mysql', `pgsql', `sip', or `none') `%s'.",
4294         ERR0107 => "Invalid value (forwarding mode must be `masq' or `tproxy') `%s'.",
4295         ERR0108 => "Invalid port number `%s'.",
4296         ERR0109 => "Invalid protocol (protocol must be `tcp') `%s'.",
4297         ERR0110 => "Invalid HTTP method (set `GET' or `HEAD') `%s'.",
4298         ERR0111 => "Invalid protocol module (should be only lowercase letters (a-z)) `%s'.",
4299         ERR0112 => "Invalid module key option (`%s' module must set `%s' option) `%s'.",
4300         ERR0113 => "Invalid QoS value (set 0 or 1-999[KMG]. must specify unit(KMG)) `%s'.",
4301         ERR0114 => "Invalid address `%s'.",
4302         ERR0115 => "Invalid address range (first value(%s) must be less than or equal to the second value(%s)) `%s'.",
4303         ERR0116 => "File not found `%s'.",
4304         ERR0117 => "File not found or cannot execute `%s'.",
4305         ERR0118 => "Unable to open logfile `%s'.",
4306         ERR0119 => "Virtual section not found for `%s'.",
4307         ERR0120 => "Unknown config `%s'.",
4308         ERR0121 => "Configuration error. Reading file `%s' at line %d: %s",
4309         ERR0122 => "Caught exception during re-read config file and re-setup l7vsd. (message: %s) "
4310                  . "So config setting will be rollbacked.",
4311         ERR0123 => "`%s' is a required module for checking %s service.",
4312         ERR0124 => "Invalid value `%s'.",
4313         ERR0125 => "Invalid accesslog rotate type (set 'date', 'size' or 'datesize') `%s'.",
4314         ERR0126 => "Invalid accesslog rotate max backup index number  `%s'.",
4315         ERR0127 => "Invalid accesslog rotate max filesize value (set 0 or 1-999[KMG]. must specify unit(KMG)) `%s'.",
4316         ERR0128 => "Invalid accesslog rotate rotation timing (set 'year','month','week','date', or 'hour') `%s'.",
4317         ERR0129 => "Invalid accesslog rotate rotation timing value `%s'.",
4318         # operate l7vsd error
4319         ERR0201 => "Failed to add virtual service to l7vsd: `%s %s', output: `%s'",
4320         ERR0202 => "Failed to edit virtual service on l7vsd: `%s %s', output: `%s'",
4321         ERR0203 => "Failed to delete virtual service from l7vsd: `%s %s', output: `%s'",
4322         ERR0204 => "Failed to add server to l7vsd: `%s %s' ( x `%s %s'), output: `%s'",
4323         ERR0205 => "Failed to edit server on l7vsd: `%s %s' ( x `%s %s'), output: `%s'",
4324         ERR0206 => "Failed to delete server from l7vsd: `%s %s' ( x `%s %s'), output: `%s'",
4325         ERR0207 => "Trying add server `%s', but virtual service `%s' is not found.",
4326         ERR0208 => "Trying delete server `%s', but virtual service `%s' is not found.",
4327         ERR0209 => "`%s' was already existed on l7vsd. ( x `%s %s')",
4328         ERR0210 => "`%s' was already deleted on l7vsd. ( x `%s %s')",
4329         ERR0211 => "`%s' was already changed to quiescent state on l7vsd. ( x `%s %s')",
4330         # command error
4331         ERR0301 => "Failed to system `%s' with return: %s",
4332         ERR0302 => "Failed to exec `%s' with return: %s",
4333         ERR0303 => "Failed to command `%s' with return: %s",
4334         # file error
4335         ERR0401 => "Failed to delete file `%s': `Is a directory'",
4336         ERR0402 => "Failed to delete file `%s': `No such file'",
4337         ERR0403 => "Failed to delete file `%s': `%s'",
4338         ERR0404 => "Config file `%s' is not found.",
4339         ERR0405 => "`l7directord.cf' is not found at default search paths.",
4340         ERR0406 => "`l7vsadm' file is not found at default search paths.",
4341         ERR0407 => "Cannot open config file `%s'.",
4342         ERR0408 => "Cannot close config file `%s'.",
4343         ERR0409 => "Cannot open pid file (%s): %s",
4344         ERR0410 => "Cannot get mtime of configuration file `%s'",
4345         ERR0411 => "No delete file specified.",
4346         ERR0412 => "Invalid pid specified. (pid: %s)",
4347         # undefined
4348         ERR0501 => "Some method arguments are undefined.",
4349         ERR0502 => "VirtualService ID is undefined.",
4350         ERR0503 => "HealthCheck ID is undefined.",
4351         ERR0504 => "negotiate function is undefined. So use check_connect function.",
4352         ERR0505 => "custom check script is undefined. So use check_off function.",
4353         # health check process
4354         ERR0601 => "Service up detected. (Real server `%s')",
4355         ERR0602 => "Service down detected. (Real server `%s')",
4356         ERR0603 => "Detected down monitor process (pid: %s). Prepare to re-start health check process. (id: `%s')",
4357         ERR0604 => "Failed to fork() on sub process creation. (id: `%s')",
4358         # daemon
4359         ERR0701 => "Cannot fork for become daemon (errno: `%s') and exit.",
4360         ERR0702 => "Cannot setsid for become daemon and exit.",
4361         ERR0703 => "Cannot chdir for become daemon and exit.",
4362         ERR0704 => "Cannot open /dev/null for become daemon and exit.",
4363         ERR0705 => "Cannot open /dev/console for become daemon and exit.",
4364
4365         # signal
4366         WRN0001 => "l7directord `%s' received signal: %s. Terminate process.",
4367         WRN0002 => "l7directord `%s' received signal: %s. Reload configuration.",
4368         WRN0003 => "Signal TERM send error(pid: %d)",
4369         WRN0004 => "Signal HUP send error(pid: %d)",
4370         # config
4371         WRN0101 => "Configuration file `%s' has changed on disk.",
4372         WRN0102 => "Reread new configuration.",
4373         WRN0103 => "Ignore new configuration.",
4374         # service check OK
4375         WRN0203 => "Service check OK. HTTP response is valid. HTTP response status line is `%s' (real - `%s:%s')",
4376         WRN0204 => "Service check OK. Successfully connect SMTP server. (real - `%s:%s')",
4377         WRN0205 => "Service check OK. Successfully connect POP3 server. (real - `%s:%s')",
4378         WRN0206 => "Service check OK. Successfully connect IMAP server. (real - `%s:%s')",
4379         WRN0207 => "Service check OK. Successfully bind LDAP server. (real - `%s:%s')",
4380         WRN0208 => "Service check OK. NNTP response is valid. `%s' (real - `%s:%s')",
4381         WRN0209 => "Service check OK. Database response is valid. (real - `%s:%s')",
4382         WRN0210 => "Service check OK. Successfully connect socket to server. (real - `%s:%s')",
4383         WRN0211 => "Service check OK. SIP response is valid. `%s' (real - `%s:%s')",
4384         WRN0212 => "Service check OK. Successfully login FTP server. (real - `%s')",
4385         WRN0213 => "Service check OK. Successfully lookup DNS. (real - `%s:%s')",
4386         WRN0214 => "Service check OK. Successfully receive ping response. (real - `%s')",
4387         WRN0215 => "Custom check result OK. (real - `%s')",
4388         # perl warn
4389         WRN0301 => "Perl warning: `%s'",
4390         # service check NG
4391         WRN1001 => "Retry service check `%s' %d more time(s).",
4392         # - http
4393         WRN1101 => "Service check NG. Check URL `%s' is not valid. (real - `%s:%s')",
4394         WRN1102 => "Service check NG. HTTP response is not ok. Response status line is `%s' (real - `%s:%s')",
4395         WRN1103 => "Service check NG. Check string `%s' is not found in HTTP response. (real - `%s:%s')",
4396         # - smtp
4397         WRN1201 => "Service check NG. Cannot connect SMTP server. (real - `%s:%s')",
4398         # - pop3
4399         WRN1301 => "Service check NG. Cannot connect POP3 server. (real - `%s:%s')",
4400         WRN1302 => "Service check NG. Cannot login POP3 server. (real - `%s:%s')",
4401         # - imap
4402         WRN1401 => "Service check NG. Cannot connect IMAP server. (real - `%s:%s')",
4403         WRN1402 => "Service check NG. Cannot login IMAP server. (real - `%s:%s')",
4404         WRN1403 => "Service check NG. Connection timeout from IMAP server in %d seconds. (real - `%s:%s')",
4405         # - ldap
4406         WRN1501 => "Service check NG. Cannot connect LDAP server. (real - `%s:%s')",
4407         WRN1502 => "Service check NG. Connection timeout from LDAP server in %d seconds. (real - `%s:%s')",
4408         WRN1503 => "Service check NG. LDAP bind error. (real - `%s:%s')",
4409         WRN1504 => "Service check NG. Exists %d results (not one) on search Base DN. (real - `%s:%s')",
4410         WRN1505 => "Service check NG. Check string `%s' is not found in Base DN search result. (real - `%s:%s')",
4411         # - nntp
4412         WRN1601 => "Service check NG. Cannot connect NNTP server. (real - `%s:%s')",
4413         WRN1602 => "Service check NG. Connection timeout from NNTP server in %d seconds. (real - `%s:%s')",
4414         WRN1603 => "Service check NG. NNTP response is not ok. `%s' (real - `%s:%s')",
4415         # - sql
4416         WRN1701 => "Service check NG. SQL check must set `database', `login', `passwd' by configuration. (real - `%s:%s')",
4417         WRN1702 => "Service check NG. Cannot connect database or cannot login database. (real - `%s:%s')",
4418         WRN1703 => "Service check NG. Query result has no row. (real - `%s:%s')",
4419         WRN1704 => "Service check NG. Expected %d rows of query results, but got %d rows. (real - `%s:%s')",
4420         WRN1705 => "Service check NG. Connection timeout from database in %d seconds. (real - `%s:%s')",
4421         # - sip
4422         WRN1801 => "Service check NG. SIP check must set `login' by configuration. (real - `%s:%s')",
4423         WRN1802 => "Service check NG. Cannot connect SIP server. (real - `%s:%s')",
4424         WRN1803 => "Service check NG. SIP response is not ok. `%s' (real - `%s:%s')",
4425         WRN1804 => "Service check NG. Connection timeout from SIP server in %d seconds. (real - `%s:%s')",
4426         # - ftp
4427         WRN1901 => "Service check NG. FTP check must set `login', `passwd' by configuration. (real - `%s')",
4428         WRN1902 => "Service check NG. Cannot connect FTP server. (real - `%s')",
4429         WRN1903 => "Service check NG. Cannot login FTP server. (real - `%s')",
4430         WRN1904 => "Service check NG. Cannot chdir to / of FTP server. (real - `%s')",
4431         WRN1905 => "Service check NG. Cannot get file `%s' (real - `%s')",
4432         WRN1906 => "Service check NG. Check string `%s' is not found in file `%s' (real - `%s')",
4433         WRN1907 => "Service check NG. Exception occur during FTP check `%s' (real - `%s')",
4434         WRN1908 => "Service check NG. Connection timeout from FTP server in %d seconds. (real - `%s')",
4435         # - dns
4436         WRN2001 => "Service check NG. DNS check must set `request', `receive' by configuration. (real - `%s:%s')",
4437         WRN2002 => "Service check NG. Connection timeout from DNS server in %d seconds. (real - `%s:%s')",
4438         WRN2003 => "Service check NG. Net::DNS exception occur `%s' (real - `%s:%s')",
4439         WRN2004 => "Service check NG. DNS search `%s' not respond. (real - `%s:%s')",
4440         WRN2005 => "Service check NG. Check string `%s' is not found in search result. (real - `%s:%s')",
4441         # - ping
4442         WRN3101 => "Service check NG. Ping timeout in %d seconds. (real - `%s')",
4443         # - connect
4444         WRN3201 => "Service check NG. Cannot connect socket to server. (errno: `%s') (real - `%s:%s')",
4445         # - custom
4446         WRN3301 => "Custom check NG. Check timeout in %d seconds. (real - `%s')",
4447         WRN3302 => "Custom check NG. `%s' returns %d",
4448
4449         # start stop
4450         INF0001 => "Starting program with command: `%s'",
4451         INF0002 => "Starting l7directord v%s with pid: %d (configuration: `%s')",
4452         INF0003 => "Starting l7directord v%s as daemon. (configuration: `%s')",
4453         INF0004 => "Exit by initialize error.",
4454         INF0005 => "Exit parent process for become daemon",
4455         INF0006 => "Exiting with exit status %d: %s",
4456         INF0007 => "Detected halt flag. Exit this monitor process with status: 0",
4457         INF0008 => "Reached end of `main'",
4458         # stderr
4459         INF0101 => "l7directord for `%s' is running with pid: %d",
4460         INF0102 => "l7directord stale pid file %s for %s",
4461         INF0103 => "Other l7directord process is running. (pid: %d)",
4462         INF0104 => "l7directord process is not running.",
4463         # l7vsd
4464         INF0201 => "Add virtual service to l7vsd: `%s %s'",
4465         INF0202 => "Edit virtual service on l7vsd: `%s %s'",
4466         INF0203 => "Delete virtual service from l7vsd: `%s %s'",
4467         INF0204 => "Add server to l7vsd: `%s %s' ( x `%s %s') (weight set to %d)",
4468         INF0205 => "Edit server on l7vsd: `%s %s' ( x `%s %s') (weight set to %d)",
4469         INF0206 => "Delete server from l7vsd: `%s %s' ( x `%s %s')",
4470         # server change
4471         INF0301 => "Added real server. (`%s')",
4472         INF0302 => "Added fallback server. (`%s')",
4473         INF0303 => "Changed real server to quiescent state. (`%s')",
4474         INF0304 => "Changed fallback server to quiescent state. (`%s')",
4475         INF0305 => "Deleted real server. (`%s')",
4476         INF0306 => "Deleted fallback server. (`%s')",
4477         # health check
4478         INF0401 => "Prepare to start health check process. (id: `%s')",
4479         INF0402 => "Create health check process with pid: %d. (id `%s')",
4480         # run
4481         INF0501 => "Real server down shell execute: `%s %s'",
4482         INF0502 => "Real server recovery shell execute: `%s %s'",
4483         INF0503 => "Config callback shell execute: `%s %s'",
4484         INF0504 => "Running system: `%s'",
4485         INF0505 => "Running exec: `%s'",
4486         INF0506 => "Running command: `%s'",
4487         };
4488
4489     my $message
4490         = exists $message_list->{$code} ? sprintf $message_list->{$code}, @message_args
4491         : "Unknown message. (code:[$code] args:[" . join(q{, }, @message_args) . '])';
4492
4493     return $message;
4494 }
4495
4496 # _message
4497 # Create message by _message_only and add code header.
4498 sub _message {
4499     my ($code, @message_args) = @_;
4500     my $message = _message_only($code, @message_args);
4501     $message = "[$code] $message";
4502     return $message;
4503 }
4504
4505 1;
4506
4507 __END__
4508
4509 =head1 NAME
4510
4511 l7directord - UltraMonkey-L7 Director Daemon
4512
4513 Daemon to monitor remote services and control UltraMonkey-L7
4514
4515
4516 =head1 SYNOPSIS
4517
4518 B<l7directord> [B<-d>] [I<configuration>] {B<start>|B<stop>|B<restart>|B<try-restart>|B<reload>|B<status>|B<configtest>}
4519
4520 B<l7directord> B<-t> [I<configuration>]
4521
4522 B<l7directord> B<-h|--help>
4523
4524 B<l7directord> B<-v|--version>
4525
4526 =head1 DESCRIPTION
4527
4528 B<l7directord> is a daemon to monitor and administer real servers in a
4529 cluster of load balanced virtual servers. B<l7directord> is similar to B<ldirectord>
4530 in terms of functionality except that it triggers B<l7vsadm>.
4531 B<l7directord> typically is started from command line but can be included
4532 to start from heartbeat. On startup B<l7directord> reads the file
4533 B</etc/ha.d/conf/>I<configuration>.
4534 After parsing the file, entries for virtual servers are created on the UltraMonkey-L7.
4535 Now at regular intervals the specified real servers are monitored and if
4536 they are considered alive, added to a list for each virtual server. If a
4537 real server fails, it is removed from that list. Only one instance of
4538 B<l7directord> can be started for each configuration, but more instances of
4539 B<l7directord> may be started for different configurations. This helps to
4540 group clusters of services.  This can be done by putting an entry inside
4541 B</etc/ha.d/haresources>
4542
4543 I<nodename virtual-ip-address l7directord::configuration>
4544
4545 to start l7directord from heartbeat.
4546
4547
4548 =head1 OPTIONS
4549
4550 =over
4551
4552 =item I<configuration>:
4553
4554 This is the name for the configuration as specified in the file
4555 B</etc/ha.d/conf/>I<configuration>
4556
4557 =item B<-d>
4558
4559 Don't start as daemon. Useful for debugging.
4560
4561 =item B<-h>
4562
4563 Help. Print user manual of l7directord.
4564
4565 =item B<-v>
4566
4567 Version. Print version of l7directord.
4568
4569 =item B<-t>
4570
4571 Run syntax tests for configuration files only. The program immediately exits after these syntax parsing tests
4572 with either a return code of 0 (Syntax OK) or return code not equal to 0 (Syntax Error).
4573
4574 =item B<start>
4575
4576 Start the daemon for the specified configuration.
4577
4578 =item B<stop>
4579
4580 Stop the daemon for the specified configuration. This is the same as sending
4581 a TERM signal to the running daemon.
4582
4583 =item B<restart>
4584
4585 Restart the daemon for the specified configuration. The same as stopping and starting.
4586
4587 =item B<try-restart>
4588
4589 Try to restart the daemon for the specified configuration. If l7directord is already running for the
4590 specified configuration, then the same is stopped and started (Similar to restart).
4591 However, if l7directord is not already running for the specified configuration, then an error message
4592 is thrown and the program exits.
4593
4594 =item B<reload>
4595
4596 Reload the configuration file. This is only useful for modifications
4597 inside a virtual server entry. It will have no effect on adding or
4598 removing a virtual server block. This is the same as sending a HUP signal to
4599 the running daemon.
4600
4601 =item B<status>
4602
4603 Show status of the running daemon for the specified configuration.
4604
4605 =item B<configtest>
4606
4607 This is the same as B<-t>.
4608
4609 =back
4610
4611
4612 =head1 SYNTAX
4613
4614 =head2 Description how to write configuration files
4615
4616 =over
4617
4618 =item B<virtual = >I<(ip_address|hostname:portnumber|servicename)>
4619
4620 Defines a virtual service by IP-address (or hostname) and port (or
4621 servicename). All real services and flags for a virtual
4622 service must follow this line immediately and be indented.
4623 For ldirectord, Firewall-mark settings could be set. But for l7directord
4624 Firewall-mark settings cannot be set.
4625
4626 =item B<checktimeout = >I<n>
4627
4628 Timeout in seconds for connect checks. If the timeout is exceeded then the
4629 real server is declared dead.  Default is 5 seconds. If defined in virtual
4630 server section then the global value is overridden.
4631
4632 =item B<negotiatetimeout = >I<n>
4633
4634 Timeout in seconds for negotiate checks. Default is 5 seconds.
4635 If defined in virtual server section then the global value is overridden.
4636
4637 =item B<checkinterval = >I<n>
4638
4639 Defines the number of second between server checks. Default is 10 seconds.
4640 If defined in virtual server section then the global value is overridden.
4641
4642 =item B<retryinterval = >I<n>
4643
4644 Defines the number of second between server checks when server status is NG.
4645 Default is 10 seconds. If defined in virtual server section then the global
4646 value is overridden.
4647
4648 =item B<checkcount = >I<n>
4649
4650 The number of times a check will be attempted before it is considered
4651 to have failed. Note that the checktimeout is additive, so if checkcount
4652 is 3 and checktimeout is 2 seconds and retryinterval is 1 second,
4653 then a total of 8 seconds (2 + 1 + 2 + 1 + 2) worth of timeout will occur
4654 before the check fails. Default is 1. If defined in virtual server section
4655 then the global value is overridden.
4656
4657 =item B<configinterval = >I<n>
4658
4659 Defines the number of second between configuration checks.
4660 Default is 5 seconds.
4661
4662 =item B<autoreload = >[B<yes>|B<no>]
4663
4664 Defines if <l7directord> should continuously check the configuration file
4665 for modification each B<configinterval> seconds. If this is set to B<yes>
4666 and the configuration file changed on disk and its modification time (mtime)
4667 is newer than the previous version, the configuration is automatically reloaded.
4668 Default is B<no>.
4669
4670 =item B<callback = ">I</path/to/callback>B<">
4671
4672 If this directive is defined, B<l7directord> automatically calls
4673 the executable I</path/to/callback> after the configuration
4674 file has changed on disk. This is useful to update the configuration
4675 file through B<scp> on the other heartbeated host. The first argument
4676 to the callback is the name of the configuration.
4677
4678 This directive might also be used to restart B<l7directord> automatically
4679 after the configuration file changed on disk. However, if B<autoreload>
4680 is set to B<yes>, the configuration is reloaded anyway.
4681
4682 =item B<fallback = >I<ip_address|hostname[:portnumber|servicename]> [B<masq>|B<tproxy>]
4683
4684 the server onto which a web service is redirected if all real
4685 servers are down. Typically this would be 127.0.0.1 with
4686 an emergency page.
4687
4688 This directive may also appear within a virtual server, in which
4689 case it will override the global fallback server, if set.
4690 Also you can set either B<masq> or B<tproxy> as fallback forwarding
4691 mechanism. The default is B<masq>.
4692
4693 =item B<logfile = ">I</path/to/logfile>B<">|syslog_facility
4694
4695 An alternative logfile might be specified with this directive. If the logfile
4696 does not have a leading '/', it is assumed to be a syslog(3) facility name.
4697
4698 The default is to log directly to the file I</var/log/l7vs/l7directord.log>.
4699
4700 =item B<execute = ">I<configuration>B<">
4701
4702 Use this directive to start an instance of l7directord for
4703 the named I<configuration>.
4704
4705 =item B<supervised>
4706
4707 If this directive is specified, the daemon does not go into background mode.
4708 All log-messages are redirected to stdout instead of a logfile.
4709 This is useful to run B<l7directord> supervised from daemontools.
4710 See http://untroubled.org/rpms/daemontools/ or http://cr.yp.to/daemontools.html
4711 for details.
4712
4713 =item B<quiescent = >[B<yes>|B<no>]
4714
4715 If B<yes>, then when real or fallback servers are determined
4716 to be down, they are not actually removed from the UltraMonkey-L7,
4717 but set weight to zero.
4718 If B<no>, then the real or fallback servers will be removed
4719 from the UltraMonkey-L7. The default is B<yes>.
4720
4721 This directive may also appear within a virtual server, in which
4722 case it will override the global fallback server, if set.
4723
4724 =back
4725
4726
4727 =head2 Section virtual
4728
4729 The following commands must follow a B<virtual> entry and must be indented
4730 with a minimum of 4 spaces or one tab.
4731
4732 =over
4733
4734 =item B<real => I<ip_address|hostname[-E<gt>ip_address|hostname][:portnumber|servicename>] [B<masq>|B<tproxy>] [I<n>] [B<">I<request>B<", ">I<receive>B<">]
4735
4736 Defines a real service by IP-address (or hostname) and port (or
4737 servicename). If the port is omitted then a 0 will be used.
4738 Optionally a range of IP addresses (or two hostnames) may be
4739 given, in which case each IP address in the range will be treated as a real
4740 server using the given port. The second argument defines the forwarding
4741 mechanism, it must be B<masq> or B<tproxy>.  The third argument defines the weight of
4742 each real service. This argument is optional. Default is 1. The last two
4743 arguments are optional too. They define a request-receive pair to be used to
4744 check if a server is alive. They override the request-receive pair in the
4745 virtual server section. These two strings must be quoted. If the request
4746 string starts with I<http://...> the IP-address and port of the real server
4747 is overridden, otherwise the IP-address and port of the real server is used.
4748
4749 =item B<module => I<proto-module module-args [opt-module-args]>
4750
4751 Indicates the module parameter of B<l7directord>. Here B<proto-module>
4752 denotes the protocol module name (For example, pfilter). B<module-args> denotes the
4753 arguments for the protocol module (For example, --pattern-match '*.html*').
4754 B<module-args> is optional only when set B<sessionless>, B<ip> and B<sslid> module to B<proto-module>.
4755 The last argument is optional (For example, --reschedule).
4756
4757 =back
4758
4759 =head2 More than one of these entries may be inside a virtual section:
4760
4761 =over
4762
4763 =item B<maxconn => I<n>
4764
4765 Defines the maximum connection that the virtual service can handle. If the number of
4766 requests cross the maxconn limit, the requests would be redirected to the
4767 sorry server.
4768
4769 =item B<qosup => I<n>[B<K>|B<M>|B<G>]
4770
4771 Defines the bandwidth quota size in bps for up stream. If the number of the
4772 bandwidth is over the qosup limit, a packet to the virtual service will be delayed
4773 until the number of bandwidth become below the qosup limit.
4774 B<K>(kilo), B<M>(mega) and B<G>(giga) unit are available.
4775
4776 =item B<qosdown => I<n>[B<K>|B<M>|B<G>]
4777
4778 Defines the bandwidth quota size in bps for down stream. If the number of the
4779 bandwidth is over the qosdown limit, a packet to the client will be delayed
4780 until the number of bandwidth become below the qosdown limit.
4781 B<K>(kilo), B<M>(mega) and B<G>(giga) unit are available.
4782
4783 =item B<sorryserver =>I<ip_address|hostname[:portnumber|servicename]> [B<masq>|B<tproxy>]
4784
4785 Defines a sorry server by IP-address (or hostname) and port (or
4786 servicename). The second argument defines the forwarding mechanism, it must be B<masq> or B<tproxy>.
4787 Firewall-mark settings cannot be set.
4788 If the number of requests to the virtual service cross the maxconn limit, or no available
4789 real server exists, then the requests would be redirected to the sorry server.
4790
4791 =item B<checktype = negotiate>|B<connect>|I<N>|B<ping>|B<custom>|B<off>|B<on>
4792
4793 Type of check to perform. Negotiate sends a request and matches a receive
4794 string. Connect only attempts to make a TCP/IP connection, thus the
4795 request and receive strings may be omitted.  If checktype is a number then
4796 negotiate and connect is combined so that after each N connect attempts one
4797 negotiate attempt is performed. This is useful to check often if a service
4798 answers and in much longer intervals a negotiating check is done. Ping
4799 means that ICMP ping will be used to test the availability of real servers.
4800 Ping is also used as the connect check for UDP services. Custom means that
4801 custom command will be used to test the availability of real servers.
4802 Off means no checking will take place and no real or fallback servers will
4803 be activated.  On means no checking will take place and real servers will
4804 always be activated. Default is I<negotiate>.
4805
4806 =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>
4807
4808 The type of service to monitor when using checktype=negotiate. None denotes
4809 a service that will not be monitored. If the port specified for the virtual
4810 server is 21, 25, 53, 80, 110, 119, 143, 389, 443, 3306, 5432 or 5060 then
4811 the default is B<ftp>, B<smtp>, B<dns>, B<http>, B<pop>, B<nntp>, B<imap>,
4812 B<ldap>, B<https>, B<mysql>, B<pgsql> or B<sip> respectively.  Otherwise the
4813 default service is B<none>.
4814
4815 =item B<checkport = >I<n>
4816
4817 Number of port to monitor. Sometimes check port differs from service port.
4818 Default is port specified for the real server.
4819
4820 =item B<request = ">I<uri to requested object>B<">
4821
4822 This object will be requested each checkinterval seconds on each real
4823 server.  The string must be inside quotes. Note that this string may be
4824 overridden by an optional per real-server based request-string.
4825
4826 For a DNS check this should the name of an A record, or the address
4827 of a PTR record to look up.
4828
4829 For a MySQL or PostgreSQL checks, this should be a SQL query.
4830 The data returned is not checked, only that the
4831 answer is one or more rows.  This is a required setting.
4832
4833 =item B<receive = ">I<regexp to compare>B<">
4834
4835 If the requested result contains this I<regexp to compare>, the real server
4836 is declared alive. The regexp must be inside quotes. Keep in mind that
4837 regexps are not plain strings and that you need to escape the special
4838 characters if they should as literals. Note that this regexp may be
4839 overridden by an optional per real-server based receive regexp.
4840
4841 For a DNS check this should be any one the A record's addresses or
4842 any one of the PTR record's names.
4843
4844 For a MySQL check, the receive setting is not used.
4845
4846 =item B<httpmethod = GET>|B<HEAD>
4847
4848 Sets the HTTP method, which should be used to fetch the URI specified in
4849 the request-string. GET is the method used by default if the parameter is
4850 not set. If HEAD is used, the receive-string should be unset.
4851
4852 =item B<virtualhost = ">I<hostname>B<">
4853
4854 Used when using a negotiate check with HTTP or HTTPS. Sets the host header
4855 used in the HTTP request.  In the case of HTTPS this generally needs to
4856 match the common name of the SSL certificate. If not set then the host
4857 header will be derived from the request url for the real server if present.
4858 As a last resort the IP address of the real server will be used.
4859
4860 =item B<login = ">I<username>B<">
4861
4862 Username to use to login to FTP, POP, IMAP, MySQL and PostgreSQL servers.
4863 For FTP, the default is anonymous. For POP and IMAP, the default is the
4864 empty string, in which case authentication will not be attempted.
4865 For a MySQL and PostgreSQL, the username must be provided.
4866
4867 For SIP the username is used as both the to and from address
4868 for an OPTIONS query. If unset it defaults to l7directord\@<hostname>,
4869 hostname is derived as per the passwd option below.
4870
4871 =item B<passwd = ">I<password>B<">
4872
4873 Password to use to login to FTP, POP, IMAP, MySQL and PostgreSQL servers.
4874 Default is for FTP is l7directord\@<hostname>, where hostname is the
4875 environment variable HOSTNAME evaluated at run time, or sourced from uname
4876 if unset. The default for all other services is an empty password, in the
4877 case of MySQL and PostgreSQL this means authentication will not be
4878 performed.
4879
4880 =item B<database = ">I<databasename>B<">
4881
4882 Database to use for MySQL and PostgreSQL servers, this is the database that
4883 the query (set by B<receive> above) will be performed against.  This is a
4884 required setting.
4885
4886 =item B<scheduler => I<scheduler_name>
4887
4888 Scheduler to be used by UltraMonkey-L7 for load balancing.
4889 The available schedulers are only B<lc> and B<rr>. The default is I<rr>.
4890
4891 =item B<protocol = tcp>
4892
4893 Protocol to be used. B<l7vsadm> supports only B<tcp>.
4894 Since the virtual is specified as an IP address and port, it would be tcp
4895 and will default to tcp.
4896
4897 =item B<realdowncallback = ">I</path/to/realdowncallback>B<">
4898
4899 If this directive is defined, B<l7directord> automatically calls
4900 the executable I</path/to/realdowncallback> after a real server's status
4901 changes to down. The first argument to the realdowncallback is the real
4902 server's IP-address and port (ip_address:portnumber).
4903
4904 =item B<realrecovercallback = ">I</path/to/realrecovercallback>B<">
4905
4906 If this directive is defined, B<l7directord> automatically calls
4907 the executable I</path/to/realrecovercallback> after a real server's status
4908 changes to up. The first argument to the realrecovercallback is the real
4909 server's IP-address and port (ip_address:portnumber).
4910
4911 =item B<customcheck = ">I<custom check command>B<">
4912
4913 If this directive is defined and set B<checktype> to custom, B<l7directord>
4914 exec custom command for real servers health checking. Only if custom command
4915 returns 0, real servers will change to up. Otherwise real servers will change
4916 to down. Custom check command has some macro string. See below.
4917
4918 =over
4919
4920 =item B<_IP_>
4921
4922 Change to real server IP address.
4923
4924 =item B<_PORT_>
4925
4926 Change to real server port number.
4927
4928 =back
4929
4930 =item B<sslconfigfile = ">I</path/to/sslconfigfile>B<">
4931
4932 When communication with Client is SSL, the file name for SSL setting is
4933 designated.
4934
4935
4936 =item B<socketoption = ">I<OPTION...>B<">
4937
4938 An option of the socket used in VirtualService is designated.
4939 The setting possible value is described.
4940
4941 =over
4942
4943 =item B<transparent>
4944
4945 Set IP_TRANSPARENT option to the RealServer socket.
4946
4947 =item B<deferaccept>
4948
4949 Set TCP_DEFER_ACCEPT option to the listener socket of VirtualService.
4950
4951 =item B<nodelay>
4952
4953 Set TCP_NODELAY option to the Client and RealServer socket.
4954
4955 =item B<cork>
4956
4957 Set TCP_CORK option to the Client and RealServer socket.
4958
4959 =item B<quickackon> or B<quickackoff>
4960
4961 Set or unset TCP_QUICKACK option to the Client and RealServer socket.
4962
4963 =back
4964
4965 =item B<accesslog = >[B<yes>|B<no>]
4966
4967 If B<yes>, then output client access log. The default is B<no>.
4968
4969 =item B<accesslog_rotate_type = >[B<date>|B<size>|B<datesize>]
4970
4971 B<date> means rotate access log with the specified date/time. B<size> means rotate access log when that file size exceeds the specified size. B<datesize> means both B<date> and B<size>.
4972
4973 =item B<accesslog_rotate_max_backup_index = >I<n>
4974
4975 Maximum number of backup files.
4976
4977 =item B<accesslog_rotate_max_filesize = > I<n>[B<K>|B<M>|B<G>]
4978
4979 Threshold file size of access log when B<accesslog_rotate_type> is set to B<size> or B<datesize>. B<K>(kilo), B<M>(mega) and B<G>(giga) units are available.
4980
4981 =item B<accesslog_rotate_rotation_timing = >[B<year>|B<month>|B<week>|B<date>|B<hour>]
4982
4983 Rotate timing type when B<accesslog_rotate_type> is set to B<date> or B<datesize>.
4984
4985 =item B<accesslog_rotate_rotation_timing_value = ">I<rotation_timing_value>B<">
4986
4987 Rotate timing. The formats are different by B<accesslog_rotate_rotation_timing> setting.
4988
4989 =over
4990
4991 =item B<accesslog_rotate_rotation_timing=year>
4992
4993 FORMAT: B<"MM/dd HH:mm">
4994
4995 =item B<accesslog_rotate_rotation_timing=month>
4996
4997 FORMAT: B<"dd HH:mm">
4998
4999 =item B<accesslog_rotate_rotation_timing=week>
5000
5001 FORMAT: B<">[B<sun>|B<mon>|B<tue>|B<wed>|B<thu>|B<fri>|B<sat>] B<HH:mm">
5002
5003 =item B<accesslog_rotate_rotation_timing=date>
5004
5005 FORMAT: B<"HH:mm">
5006
5007 =item B<accesslog_rotate_rotation_timing=hour>
5008
5009 FORMAT: B<"mm">
5010
5011 Defines the size each of session_thread_pool_size.
5012 Default is session_thread_pool_size parameter at l7vs.cf.
5013
5014 =item B<session_thread_pool_size = >I<n>
5015
5016 =back
5017
5018 =back
5019
5020
5021 =head1 FILES
5022
5023 B</etc/ha.d/conf/l7directord.cf>
5024
5025 B</var/log/l7vs/l7directord.log>
5026
5027 B</var/run/l7directord.>I<configuration>B<.pid>
5028
5029 B</etc/services>
5030
5031 =head1 SEE ALSO
5032
5033 L<l7vsadm>, L<heartbeat>
5034
5035
5036 =head1 AUTHORS
5037
5038 NTT COMWARE
5039
5040 =cut