l7directord/l7directord

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