l7directord/l7directord

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