l7directord/l7directord

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