#! /usr/bin/perl # Copyright (c) 2014-2016 Henk P. Penning. # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are # met: # # 1. Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # # 2. Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the # distribution. # # THIS SOFTWARE IS PROVIDED BY Henk P. Penning, ``AS # IS'' AND ANY # EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR # PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL Henk P. Penning OR # CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, # EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, # PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR # PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF # LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING # NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. # # The views and conclusions contained in the software and documentation # are those of the author and should not be interpreted as representing # official policies, either expressed or implied, of anyone/thing else. # --------------------------------------------------------------------- # "Simplified BSD License" or "FreeBSD License" # http://en.wikipedia.org/wiki/BSD_licenses # --------------------------------------------------------------------- # Note : version '0.14' of Proc::Daemon is included in this package, # with one change : umask(0) -> umask(022) ; because it fixes a bug. # See the Proc::Daemon copyright notice in arlogd-{server,client}. ################################################################################ ## File: ## Daemon.pm ## Authors: ## Earl Hood earl@earlhood.com ## Detlef Pilzecker deti@cpan.org ## Description: ## Run Perl program(s) as a daemon process, see docu in the Daemon.pod file ################################################################################ ## Copyright (C) 1997-2011 by Earl Hood and Detlef Pilzecker. ## ## All rights reserved. ## ## This module is free software. It may be used, redistributed and/or modified ## under the same terms as Perl itself. ################################################################################ package Proc::Daemon; no warnings 'once' ; use strict; use POSIX(); $Proc::Daemon::VERSION = '0.14'; ################################################################################ # Create the Daemon object: # my $daemon = Proc::Daemon->new( [ %Daemon_Settings ] ) # # %Daemon_Settings are hash key=>values and can be: # work_dir => '/working/daemon/directory' -> defaults to '/' # setuid => 12345 -> defaults to # child_STDIN => '/path/to/daemon/STDIN.file' -> defautls to ' '/path/to/daemon/STDOUT.file' -> defaults to '+>/dev/null' # child_STDERR => '/path/to/daemon/STDERR.file' -> defaults to '+>/dev/null' # dont_close_fh => [ 'main::DATA', 'PackageName::DATA', 'STDOUT', ... ] # -> arrayref with file handles you do not want to be closed in the daemon. # dont_close_fd => [ 5, 8, ... ] -> arrayref with file # descriptors you do not want to be closed in the daemon. # pid_file => '/path/to/pid/file.txt' -> defaults to # undef (= write no file). # exec_command => 'perl /home/script.pl' -> execute a system command # via Perls *exec PROGRAM* at the end of the Init routine and never return. # Must be an arrayref if you want to create several daemons at once. # # Returns: the blessed object. ################################################################################ sub new { my ( $class, %args ) = @_; my $self = \%args; bless( $self, $class ); $self->{memory} = {}; return $self; } ################################################################################ # Become a daemon: # $daemon->Init # # or, for more daemons with other settings in the same script: # Use a hash as below. The argument must (!) now be a hashref: {...} # even if you don't modify the initial settings (=> use empty hashref). # $daemon->Init( { [ %Daemon_Settings ] } ) # # or, if no Daemon->new() object was created and for backward compatibility: # Proc::Daemon::Init( [ { %Daemon_Settings } ] ) # In this case the argument must be or a hashref! # # %Daemon_Settings see &new. # # Returns to the parent: # - nothing (parent does exit) if the context is looking for no return value. # - the PID(s) of the daemon(s) created. # Returns to the child (daemon): # its PID (= 0) | never returns if used with 'exec_command'. ################################################################################ sub Init { my Proc::Daemon $self = shift; my $settings_ref = shift; # Check if $self has been blessed into the package, otherwise do it now. unless ( ref( $self ) && eval{ $self->isa( 'Proc::Daemon' ) } ) { $self = ref( $self ) eq 'HASH' ? Proc::Daemon->new( %$self ) : Proc::Daemon->new(); } # If $daemon->Init is used again in the same script, # update to the new arguments. elsif ( ref( $settings_ref ) eq 'HASH' ) { map { $self->{ $_ } = $$settings_ref{ $_ } } keys %$settings_ref; } # Open a filehandle to an anonymous temporary pid file. If this is not # possible (some environments do not allow all users to use anonymous # temporary files), use the pid_file(s) to retrieve the PIDs for the parent. my $FH_MEMORY; unless ( open( $FH_MEMORY, "+>", undef ) || $self->{pid_file} ) { die "Can not anonymous temporary pidfile ('$!'), therefore you must add 'pid_file' as an Init() argument, e.g. to: '/tmp/proc_daemon_pids'"; } # Get the file descriptors the user does not want to close. my %dont_close_fd; if ( defined $self->{dont_close_fd} ) { die "The argument 'dont_close_fd' must be arrayref!" if ref( $self->{dont_close_fd} ) ne 'ARRAY'; foreach ( @{ $self->{dont_close_fd} } ) { die "All entries in 'dont_close_fd' must be numeric ('$_')!" if $_ =~ /\D/; $dont_close_fd{ $_ } = 1; } } # Get the file descriptors of the handles the user does not want to close. if ( defined $self->{dont_close_fh} ) { die "The argument 'dont_close_fh' must be arrayref!" if ref( $self->{dont_close_fh} ) ne 'ARRAY'; foreach ( @{ $self->{dont_close_fh} } ) { if ( defined ( my $fn = fileno $_ ) ) { $dont_close_fd{ $fn } = 1; } } } # If system commands are to be executed, put them in a list. my @exec_command = ref( $self->{exec_command} ) eq 'ARRAY' ? @{ $self->{exec_command} } : ( $self->{exec_command} ); $#exec_command = 0 if $#exec_command < 0; # Create a daemon for every system command. foreach my $exec_command ( @exec_command ) { # The first parent is running here. # Using this subroutine or loop multiple times we must modify the filenames: # 'child_STDIN', 'child_STDOUT', 'child_STDERR' and 'pid_file' for every # daemon (a higher number will be appended to the filenames). $self->adjust_settings(); # First fork. my $pid = Fork(); if ( defined $pid && $pid == 0 ) { # The first child runs here. # Set the new working directory. die "Can't to $self->{work_dir}: $!" unless chdir $self->{work_dir}; # Clear the file creation mask. umask 022 ; # Detach the child from the terminal (no controlling tty), make it the # session-leader and the process-group-leader of a new process group. die "Cannot detach from controlling terminal" if POSIX::setsid() < 0; # "Is ignoring SIGHUP necessary? # # It's often suggested that the SIGHUP signal should be ignored before # the second fork to avoid premature termination of the process. The # reason is that when the first child terminates, all processes, e.g. # the second child, in the orphaned group will be sent a SIGHUP. # # 'However, as part of the session management system, there are exactly # two cases where SIGHUP is sent on the death of a process: # # 1) When the process that dies is the session leader of a session that # is attached to a terminal device, SIGHUP is sent to all processes # in the foreground process group of that terminal device. # 2) When the death of a process causes a process group to become # orphaned, and one or more processes in the orphaned group are # stopped, then SIGHUP and SIGCONT are sent to all members of the # orphaned group.' [2] # # The first case can be ignored since the child is guaranteed not to have # a controlling terminal. The second case isn't so easy to dismiss. # The process group is orphaned when the first child terminates and # POSIX.1 requires that every STOPPED process in an orphaned process # group be sent a SIGHUP signal followed by a SIGCONT signal. Since the # second child is not STOPPED though, we can safely forego ignoring the # SIGHUP signal. In any case, there are no ill-effects if it is ignored." # Source: http://code.activestate.com/recipes/278731/ # # local $SIG{'HUP'} = 'IGNORE'; # Second fork. # This second fork is not absolutely necessary, it is more a precaution. # 1. Prevent possibility of reacquiring a controlling terminal. # Without this fork the daemon would remain a session-leader. In # this case there is a potential possibility that the process could # reacquire a controlling terminal. E.g. if it opens a terminal device, # without using the O_NOCTTY flag. In Perl this is normally the case # when you use on this kind of device, instead of # with the O_NOCTTY flag set. # Note: Because of the second fork the daemon will not be a session- # leader and therefore Signals will not be send to other members of # his process group. If you need the functionality of a session-leader # you may want to call POSIX::setsid() manually on your daemon. # 2. Detach the daemon completely from the parent. # The double-fork prevents the daemon from becoming a zombie. It is # needed in this module because the grandparent process can continue. # Without the second fork and if a child exits before the parent # and you forget to call in the parent you will get a zombie # until the parent also terminates. Using the second fork we can be # sure that the parent of the daemon is finished near by or before # the daemon exits. $pid = Fork(); if ( defined $pid && $pid == 0 ) { # Here the second child is running. # Close all file handles and descriptors the user does not want # to preserve. my $hc_fd; # highest closed file descriptor close $FH_MEMORY; foreach ( 0 .. OpenMax() ) { unless ( $dont_close_fd{ $_ } ) { if ( $_ == 0 ) { close STDIN } elsif ( $_ == 1 ) { close STDOUT } elsif ( $_ == 2 ) { close STDERR } else { $hc_fd = $_ if POSIX::close( $_ ) } } } # Sets the real user identifier and the effective user # identifier for the daemon process before opening files. POSIX::setuid( $self->{setuid} ) if defined $self->{setuid}; # Reopen STDIN, STDOUT and STDERR to 'child_STD...'-path or to # /dev/null. Data written on a null special file is discarded. # Reads from the null special file always return end of file. open( STDIN, $self->{child_STDIN} || "{child_STDOUT} || "+>/dev/null" ) unless $dont_close_fd{ 1 }; open( STDERR, $self->{child_STDERR} || "+>/dev/null" ) unless $dont_close_fd{ 2 }; # Since is in some cases "secretly" closing # file descriptors without telling it to perl, we need to # re and as many files as we closed with # . Otherwise it can happen (especially with # FH opened by __DATA__ or __END__) that there will be two perl # handles associated with one file, what can cause some # confusion. :-) # see: http://rt.perl.org/rt3/Ticket/Display.html?id=72526 if ( $hc_fd ) { my @fh; foreach ( 3 .. $hc_fd ) { open $fh[ $_ ], ", , or # following . The function executes a system # command and never returns. } # Return the childs own PID (= 0) return $pid; } # First child (= second parent) runs here. # Print the PID of the second child into ... $pid ||= ''; # ... the anonymous temporary pid file. if ( $FH_MEMORY ) { print $FH_MEMORY "$pid\n"; close $FH_MEMORY; } # ... the real 'pid_file'. if ( $self->{pid_file} ) { open( my $FH_PIDFILE, "+>", $self->{pid_file} ) || die "Can not open pidfile (pid_file => '$self->{pid_file}'): $!"; print $FH_PIDFILE $pid; close $FH_PIDFILE; } # Don't for the second child to exit, # even if we don't have a value in $exec_command. # The second child will become orphan by here, but then it # will be adopted by init(8), which automatically performs a # to remove the zombie when the child exits. exit; } # Only first parent runs here. # A child that terminates, but has not been waited for becomes # a zombie. So we wait for the first child to exit. waitpid( $pid, 0 ); } # Only first parent runs here. # Exit if the context is looking for no value (void context). exit 0 unless defined wantarray; # Get the daemon PIDs out of the anonymous temporary pid file # or out of the real pid-file(s) my @pid; if ( $FH_MEMORY ) { seek( $FH_MEMORY, 0, 0 ); @pid = map { chomp $_; $_ eq '' ? undef : $_ } <$FH_MEMORY>; close $FH_MEMORY; } elsif ( $self->{memory}{pid_file} ) { foreach ( keys %{ $self->{memory}{pid_file} } ) { open( $FH_MEMORY, "<", $_ ) || die "Can not open pid_file '<$_': $!"; push( @pid, <$FH_MEMORY> ); close $FH_MEMORY; } } # Return the daemon PIDs (from second child/ren) to the first parent. return ( wantarray ? @pid : $pid[0] ); } # For backward capability: *init = \&Init; ################################################################################ # Set some defaults and adjust some settings. # Args: ( $self ) # Returns: nothing ################################################################################ sub adjust_settings { my Proc::Daemon $self = shift; # Set default 'work_dir' if needed. $self->{work_dir} ||= '/'; $self->fix_filename( 'child_STDIN', 1 ) if $self->{child_STDIN}; $self->fix_filename( 'child_STDOUT', 1 ) if $self->{child_STDOUT}; $self->fix_filename( 'child_STDERR', 1 ) if $self->{child_STDERR}; # Check 'pid_file's name if ( $self->{pid_file} ) { die "Pidfile (pid_file => '$self->{pid_file}') can not be only a number. I must be able to distinguish it from a PID number in &get_pid('...')." if $self->{pid_file} =~ /^\d+$/; $self->fix_filename( 'pid_file' ); } return; } ################################################################################ # - If the keys value is only a filename add the path of 'work_dir'. # - If we have already set a file for this key with the same "path/name", # add a number to the file. # Args: ( $self, $key, $extract_mode ) # key: one of 'child_STDIN', 'child_STDOUT', 'child_STDERR', 'pid_file' # extract_mode: true = separate MODE form filename before checking # path/filename; false = no MODE to check # Returns: nothing ################################################################################ sub fix_filename { my Proc::Daemon $self = shift; my $key = shift; my $var = $self->{ $key }; my $mode = ( shift ) ? ( $var =~ s/^([\+\<\>\-\|]+)// ? $1 : ( $key eq 'child_STDIN' ? '<' : '+>' ) ) : ''; # add path to filename if ( $var =~ s/^\.\/// || $var !~ /\// ) { $var = $self->{work_dir} =~ /\/$/ ? $self->{work_dir} . $var : $self->{work_dir} . '/' . $var; } # If the file was already in use, modify it with '_number': # filename_X | filename_X.ext if ( $self->{memory}{ $key }{ $var } ) { $var =~ s/([^\/]+)$//; my @i = split( /\./, $1 ); my $j = $#i ? $#i - 1 : 0; $self->{memory}{ "$key\_num" } ||= 0; $i[ $j ] =~ s/_$self->{memory}{ "$key\_num" }$//; $self->{memory}{ "$key\_num" }++; $i[ $j ] .= '_' . $self->{memory}{ "$key\_num" }; $var .= join( '.', @i ); } $self->{memory}{ $key }{ $var } = 1; $self->{ $key } = $mode . $var; return; } ################################################################################ # Fork(): Retries to fork over 30 seconds if possible to fork at all and # if necessary. # Returns the child PID to the parent process and 0 to the child process. # If the fork is unsuccessful it Cs and returns C. ################################################################################ sub Fork { my $pid; my $loop = 0; FORK: { if ( defined( $pid = fork ) ) { return $pid; } # EAGAIN - fork cannot allocate sufficient memory to copy the parent's # page tables and allocate a task structure for the child. # ENOMEM - fork failed to allocate the necessary kernel structures # because memory is tight. # Last the loop after 30 seconds if ( $loop < 6 && ( $! == POSIX::EAGAIN() || $! == POSIX::ENOMEM() ) ) { $loop++; sleep 5; redo FORK; } } warn "Can't fork: $!"; return undef; } ################################################################################ # OpenMax( [ NUMBER ] ) # Returns the maximum number of possible file descriptors. If sysconf() # does not give me a valid value, I return NUMBER (default is 64). ################################################################################ sub OpenMax { my $openmax = POSIX::sysconf( &POSIX::_SC_OPEN_MAX ); return ( ! defined( $openmax ) || $openmax < 0 ) ? ( shift || 64 ) : $openmax; } ################################################################################ # Check if the (daemon) process is alive: # Status( [ number or string ] ) # # Examples: # $object->Status() - Tries to get the PID out of the settings in new() and checks it. # $object->Status( 12345 ) - Number of PID to check. # $object->Status( './pid.txt' ) - Path to file containing one PID to check. # $object->Status( 'perl /home/my_perl_daemon.pl' ) - Command line entry of the # running program to check. Requires Proc::ProcessTable to work. # # Returns the PID (alive) or 0 (dead). ################################################################################ sub Status { my Proc::Daemon $self = shift; my $pid = shift; # Get the process ID. ( $pid, undef ) = $self->get_pid( $pid ); # Return if no PID was found. return 0 if ! $pid; # The kill(2) system call will check whether it's possible to send # a signal to the pid (that means, to be brief, that the process # is owned by the same user, or we are the super-user). This is a # useful way to check that a child process is alive (even if only # as a zombie) and hasn't changed its UID. return ( kill( 0, $pid ) ? $pid : 0 ); } ################################################################################ # Kill the (daemon) process: # Kill_Daemon( [ number or string [, SIGNAL ] ] ) # # Examples: # $object->Kill_Daemon() - Tries to get the PID out of the settings in new() and kill it. # $object->Kill_Daemon( 12345, 'TERM' ) - Number of PID to kill with signal 'TERM'. The # names or numbers of the signals are the ones listed out by kill -l on your system. # $object->Kill_Daemon( './pid.txt' ) - Path to file containing one PID to kill. # $object->Kill_Daemon( 'perl /home/my_perl_daemon.pl' ) - Command line entry of the # running program to kill. Requires Proc::ProcessTable to work. # # Returns the number of processes successfully killed, # which mostly is not the same as the PID number. ################################################################################ sub Kill_Daemon { my Proc::Daemon $self = shift; my $pid = shift; my $signal = shift || 'KILL'; my $pidfile; # Get the process ID. ( $pid, $pidfile ) = $self->get_pid( $pid ); # Return if no PID was found. return 0 if ! $pid; # Kill the process. my $killed = kill( $signal, $pid ); if ( $killed && $pidfile ) { # Set PID in pid file to '0'. if ( open( my $FH_PIDFILE, "+>", $pidfile ) ) { print $FH_PIDFILE '0'; close $FH_PIDFILE; } else { warn "Can not open pidfile (pid_file => '$pidfile'): $!" } } return $killed; } ################################################################################ # Return the PID of a process: # get_pid( number or string ) # # Examples: # $object->get_pid() - Tries to get the PID out of the settings in new(). # $object->get_pid( 12345 ) - Number of PID to return. # $object->get_pid( './pid.txt' ) - Path to file containing the PID. # $object->get_pid( 'perl /home/my_perl_daemon.pl' ) - Command line entry of # the running program. Requires Proc::ProcessTable to work. # # Returns an array with ( 'the PID | ', 'the pid_file | ' ) ################################################################################ sub get_pid { my Proc::Daemon $self = shift; my $string = shift || ''; my ( $pid, $pidfile ); if ( $string ) { # $string is already a PID. if ( $string =~ /^\d+$/ ) { $pid = $string; } # Open the pidfile and get the PID from it. elsif ( open( my $FH_MEMORY, "<", $string ) ) { $pid = <$FH_MEMORY>; close $FH_MEMORY; die "I found no valid PID ('$pid') in the pidfile: '$string'" if $pid =~ /\D/s; $pidfile = $string; } # Get the PID by the system process table. else { $pid = $self->get_pid_by_proc_table_attr( 'cmndline', $string ); } } # Try to get the PID out of the new() settings. if ( ! $pid ) { # Try to get the PID out of the 'pid_file' setting. if ( $self->{pid_file} && open( my $FH_MEMORY, "<", $self->{pid_file} ) ) { $pid = <$FH_MEMORY>; close $FH_MEMORY; if ( ! $pid || ( $pid && $pid =~ /\D/s ) ) { $pid = undef } else { $pidfile = $self->{pid_file} } } # Try to get the PID out of the system process # table by the 'exec_command' setting. if ( ! $pid && $self->{exec_command} ) { $pid = $self->get_pid_by_proc_table_attr( 'cmndline', $self->{exec_command} ); } } return ( $pid, $pidfile ); } ################################################################################ # This sub requires the Proc::ProcessTable module to be installed!!! # # Search for the PID of a process in the process table: # $object->get_pid_by_proc_table_attr( 'unix_process_table_attribute', 'string that must match' ) # # unix_process_table_attribute examples: # For more see the README.... files at http://search.cpan.org/~durist/Proc-ProcessTable/ # uid - UID of process # pid - process ID # ppid - parent process ID # fname - file name # state - state of process # cmndline - full command line of process # cwd - current directory of process # # Example: # get_pid_by_proc_table_attr( 'cmndline', 'perl /home/my_perl_daemon.pl' ) # # Returns the process PID on success, otherwise . ################################################################################ sub get_pid_by_proc_table_attr { my Proc::Daemon $self = shift; my ( $command, $match ) = @_; my $pid; # eval - Module may not be installed eval { require Proc::ProcessTable; my $table = Proc::ProcessTable->new()->table; foreach ( @$table ) { # fix for Proc::ProcessTable: under some conditions $_->cmndline # retruns with space and/or other characters at the end next unless $_->$command =~ /^$match\s*$/; $pid = $_->pid; last; } }; warn "- Problem in get_pid_by_proc_table_attr( '$command', '$match' ):\n $@ You may not use a command line entry to get the PID of your process.\n This function requires Proc::ProcessTable (http://search.cpan.org/~durist/Proc-ProcessTable/) to work.\n" if $@; return $pid; } 1 ; #! /usr/bin/perl use strict ; use warnings ; use Carp ; package main ; our $HAVE_ARENA ; BEGIN { my $ARENA = 'Devel::Gladiator qw(walk_arena arena_ref_counts)' ; if ( eval "use $ARENA ; 1 ;" ) { $HAVE_ARENA = 1 ; } # else { print "can't use $ARENA\n" ; } } our $NAME = 'arlogd' ; our $VERSION = '0.1.8' ; our $REVISION = '188' ; our $LCL_HOST = '127.0.0.1' ; our $IP_PAT = '^\d{1,3}(\.\d{1,3}){3}$' ; our $BUF_SIZE = 8 * 1024 ; our $MUX_TIMEOUT = 60 ; our $WHO_IAM = undef ; our $PROG = substr $0, 1 + rindex $0, '/' ; our $STAT = 'state' ; our $MODE = 0 ; our $STOP = 'dirty' ; our $STPR = undef ; our $PRIV = 'old' ; our $ROT = 'rot' ; our $INIT = 0 ; our $DEF_CONF_FILE = "$NAME.conf" ; our @DEF_CONF_FILES = ( $DEF_CONF_FILE, "/etc/$NAME/conf" ) ; our $DEF_ALLOW_HOST = 'localhost' ; our $HOSTNAME = `hostname` || 'no_hostname' ; chomp $HOSTNAME ; our $CONF ; sub NAME { $NAME ; } sub VERSION { "$NAME-$VERSION" ; } sub WHO_IAM { $WHO_IAM = shift if @_ ; $WHO_IAM ; } sub MODE { $MODE ; } sub STPR { $STPR ; } sub STOP { $STOP = shift if @_ ; $STOP ; } sub INITx { $INIT = shift if @_ ; $INIT ; } sub REVISION { ( map { /(\d+)/ ; $1 ; } ( `svn info -r HEAD | grep Revision` ) ) [ 0 ] ; } our $ALLOW_DATA = {} ; our $ALLOW_META = { $LCL_HOST => 1 } ; sub FIFOS { $CONF -> { FIFOS } ; } our $NAME1 = $NAME ; chop $NAME1 ; our @LEVELS = qw(SILENT QUIET TERSE VERBOSE DEBUG) ; our %LEVELS = () ; { my $cnt = 0 ; for my $nam ( @LEVELS ) { $LEVELS { $cnt } = $nam ; $LEVELS { $nam } = $cnt ++ ; } } our $LOG_LEVEL ; $LOG_LEVEL = $LEVELS { DEBUG } ; $LOG_LEVEL = $LEVELS { VERBOSE } ; our $SYS_LEVEL = $LEVELS { QUIET } ; $SIG{ALRM} = sub { logt ( "ALRM" ) ; die "timed out" ; } ; sub start_up { my $prog = shift ; my $CONF = shift ; my $opt = shift ; my $USG = <def_conf_files()]} option version : print version and exit ------------------------------------------------------- @{[Conf::def_conf()]} HELP # usage: &GetOptions(ARG,ARG,..) defines $opt_ID as 1 or user spec'ed value # usage: &GetOptions(\%opt,ARG,ARG,..) defines $opt{ID} as 1 or user value # ARG = 'ID' | 'ID=SPC' | 'ID:SPC' for no-arg, required-arg or optional-arg # ID = perl identifier # SPC = i|f|s for integer, fixedpoint real or string argument use Getopt::Long ; Getopt::Long::config ( 'no_ignore_case' ) ; my @res = () ; my @errs = () ; my @wrns = () ; my $slnt = scalar grep $_ eq '-s', @ARGV ; my $t = 'startup' ; $SIG{__WARN__} = sub { my $err = shift ; chomp $err ; push @res, $err if defined $err ; } ; GetOptions ( $opt, qw(help s c=s t version) ) ; if ( $opt->{help} ) { print $USG, $HELP ; exit 0 ; } if ( $opt->{version} ) { printf "%s-%s\n", $VERSION, '188' ; exit ; } for my $err ( @res ) { if ( $err =~ /^Unknown option:/ ) { push @wrns, "[options] $err" ; } else { push @errs, "[options] $err" ; } } push @errs, "[$t] Arg count" unless @ARGV <= 1 ; push @wrns, $USG if $CONF -> cnt_all and ! $slnt ; INITx ( 1 ) if $opt->{s} ; my $ARG = shift @ARGV || '' ; push @errs, "[$t] Bad argument [$ARG]" if $ARG and $ARG !~ /^(stop|start|state)$/ ; $CONF -> _add_err ( $_ ) for @errs ; $CONF -> _add_wrn ( $_ ) for @wrns ; return $ARG ; } ############################################################## package Util ; use Exporter ; use Net::hostent ; use Socket ; our ( @EXPORT, @EXPORT_OK, @ISA ) ; BEGIN { require Exporter ; @EXPORT = qw(logs logq logt logv logd basename dirname) ; @EXPORT_OK = qw() ; @ISA = qw(Exporter) } our $LOGGER = undef ; sub logger { unless ( defined $LOGGER ) { $LOGGER = '' ; for my $root ( '', '/usr' ) { for my $bin ( qw(bin sbin) ) { my $prg = "$root/$bin/logger" ; if ( -f $prg ) { $LOGGER = $prg ; return $LOGGER ; } } } } $LOGGER ; } our $_addlog = 0 ; our $LOGF_hndl ; sub addlog { my $msg = shift ; return unless $CONF and ref ( $CONF ) eq 'Conf' ; my $LOGF = $CONF -> { LOGF } ; unless ( $LOGF_hndl and defined $LOGF_hndl -> fileno ) { $CONF -> priv_old ; unless ( $LOGF_hndl = new IO::File ">>$LOGF" ) { logq ( "can't append [$LOGF] ($!)" ) unless $_addlog ++ ; } $LOGF_hndl -> autoflush ( 1 ) ; $CONF -> priv_new ; } if ( $LOGF_hndl ) { $LOGF_hndl -> printf ( "%s %s[%s] %s\n", scalar ( localtime ) , $PROG, $$, $msg ) ; $_addlog = 0 ; } } sub syslog { return unless $MODE or $INIT ; my $logger = logger ; if ( $logger and open SYSL, "|$logger -p user.err -t ${PROG}[$$]" ) { printf SYSL @_ ; close SYSL ; } } sub rotlog { return unless $CONF and ref ( $CONF ) eq 'Conf' ; my $LOGF = $CONF -> { LOGF } ; my $LOGR = $CONF -> { LOGR } ; return unless $LOGR ; undef $LOGF_hndl ; $_addlog = 0 ; unlink "$LOGF.$LOGR" ; # ignore status for ( my $i = $LOGR - 1 ; $i > 0 ; $i -- ) { my $src = sprintf "%s.%s", $LOGF, $i ; my $dst = sprintf "%s.%s", $LOGF, $i + 1 ; rename $src, $dst or syslog "can't rename $src, $dst" if -f $src ; } my $dst = "$LOGF.1" ; rename $LOGF, $dst or addlog "can't rename $LOGF, $dst" if -f $LOGF ; my $msg = "can't re-open" ; close STDOUT ; open STDOUT, '>>', $LOGF or syslog "$msg STDOUT" ; close STDERR ; open STDERR, '>>', $LOGF or syslog "$msg STDERR" ; } sub logx { my $lvl = shift ; if ( $lvl <= $LOG_LEVEL ) { # sprintf can't have a @list as first argument my ( $fmt, @args ) = @_ ; my $msg = sprintf $fmt, @args ; chomp $msg ; if ( $MODE or $INIT ) { addlog $msg ; syslog $msg if $lvl <= $SYS_LEVEL ; } else { print "$msg\n" ; } } } for my $lvl ( @LEVELS ) { my $ini = lc substr $lvl, 0, 1 ; my $num = $LEVELS { $lvl } ; my $sub = "sub log$ini { logx ( $num, \@_ ) ; }" ; eval $sub ; die $@ if $@ ; } sub make_secr { my $res = '' ; my @abc = ( 'a' .. 'z' ) ; for my $i ( 1 .. 12 ) { $res .= $abc [ int rand ( 26 ) ] ; } $res ; } sub get_host_ips { my $host = shift ; my $res = undef ; if ( $host =~ /$IP_PAT/ ) { $res = [ $host ] ; } elsif ( my $info = gethost $host ) { $res = [ map { inet_ntoa $_ ; } @{ $info -> addr_list } ] ; } $res ; } sub basename { my $x = shift || $0 ; substr $x, 1 + rindex $x, '/' ; } sub dirname { my $x = shift || $0 ; my $idx = rindex $x, '/' ; ( $idx == -1 ) ? '.' : substr $x, 0, $idx ; } sub find ; sub find { my $dir = shift ; my $sub = shift ; my @arg = @_ ; my @res = () ; if ( opendir DIR, $dir ) { my @dir = map { "$dir/$_" ; } grep ! /^\./, readdir DIR ; closedir DIR ; for my $itm ( @dir ) { next if -l $itm ; push @res, $itm if &$sub ( $itm, @arg ) ; push @res, find $itm, $sub, @arg if -d $itm ; } } else { logt ( "find: can't opendir $dir ($!)" ) ; } @res ; } sub bad_pref { my $pref = shift ; my $res = ! defined $pref ; $res ||= $pref eq '' ; $res ||= $pref =~ m!^/! ; $res ||= scalar grep $_ eq '..', split '/', $pref ; $res ; } ############################################################## package Dmon ; use Fcntl qw(:flock) ; BEGIN{ Proc::Daemon -> import() ; } ; use IO::Handle ; use IO::Socket::INET ; Util -> import ; sub new { my $self = shift ; bless {}, $self ; } sub Init { my $self = shift ; my $LOGF = $CONF -> logfile ; $self -> { dmon } = Proc::Daemon -> new ( work_dir => '.' , child_STDOUT => ">>$LOGF" , child_STDERR => ">>$LOGF" , pid_file => $CONF -> pid_file ) ; $self ; } sub Make { my $self = shift ; $self -> new -> Init ; } sub dmon { my $self = shift ; $self -> { dmon } ; } sub lck_file { my $self = shift ; $CONF -> lck_file ; } sub pid_file { my $self = shift ; $CONF -> pid_file ; } sub stp_file { my $self = shift ; $CONF -> stp_file ; } sub make_stp { my $self = shift ; my $file = $self -> stp_file ; if ( open STOP, ">$file" ) { $STPR = Util::make_secr ; printf STOP "%s\n", $STPR ; close STOP ; chmod 0600, $file or logt ( "can't chmod $file" ) ; } else { logt ( "can't write stop file [$file] ($!) ; nevermind" ) ; } } sub read_stp { my $self = shift ; my $file = $self -> stp_file ; my $res = undef ; if ( open STOP, $file ) { chomp ( $res = ) ; close STOP ; } else { logt ( "can't read stop file [$file] ($!) ; nevermind" ) ; } $res ; } sub rm_stp { my $self = shift ; unlink $self -> stp_file ; } sub xlock { my $self = shift ; my $file = $self -> lck_file ; my $cnt = 0 ; my $res = 0 ; unless ( open LOCK, ">$file" ) { logq ( "exit ; can't write lock file [$file] ($!)" ) ; exit ; } while ( $cnt < 2 ) { $cnt ++ ; if ( flock LOCK, LOCK_EX|LOCK_NB ) { logd ( "got lock ; try[$cnt]" ) ; $res = 1 ; last ; } else { logd ( "can't get lock ; try[$cnt]" ) ; } sleep 5 ; } $res ; } sub ulock { my $self = shift ; flock LOCK, LOCK_UN ; } # pid # already running # -1 # can't lock # 0 # we're the daemon sub start_daemon { my $self = shift ; my $pid = undef ; my $dmon = $self -> dmon ; my $msg ; my $cnt = 0 ; while ( $cnt < 3 and $pid = $dmon -> Status ( undef ) ) { $cnt ++ ; sleep 1 ; } if ( $pid ) { $msg = "$PROG: '$WHO_IAM' is already running ; pid $pid" ; } elsif ( ! $self -> xlock ) { $msg = "$PROG: can't lock ; some '$WHO_IAM' is already running" ; $pid = -1 ; } else { $self -> ulock ; $pid = $dmon -> Init () ; $msg = sprintf "$PROG: launched $WHO_IAM on %s ; pid %s" , $HOSTNAME, $pid ; } return $pid, $msg ; } sub send_stop { my $self = shift ; my $res = 0 ; my $SOCK = IO::Socket::INET -> new ( PeerAddr => 'localhost' , PeerPort => $CONF -> PORT + ( $WHO_IAM eq 'server' ? 1 : 2 ) , Proto => 'tcp' ) ; if ( $SOCK ) { printf $SOCK "STOP %s\n", ( $self -> read_stp || '_' ) ; $SOCK -> shutdown ( 1 ) ; # done writing my $line = <$SOCK> ; chomp $line ; $res = 1 if $line eq 'STOPPED' ; $SOCK -> shutdown ( 2 ) ; # done reading } else { logv ( "can't open sock ; nevermind" ) ; } $res ; } sub send_state { my $self = shift ; my $res = '' ; my $SOCK = IO::Socket::INET -> new ( PeerAddr => 'localhost' , PeerPort => $CONF -> PORT + ( $WHO_IAM eq 'server' ? 1 : 2 ) , Proto => 'tcp' ) ; if ( $SOCK ) { printf $SOCK "STATE\n" ; $SOCK -> shutdown ( 1 ) ; # done writing $res = join '', <$SOCK> ; $SOCK -> shutdown ( 2 ) ; # done reading } else { $res = "can't open sock to daemon" ; } $res ; } sub stop_daemon { my $self = shift ; $self -> dmon -> Kill_Daemon ( undef, 'HUP' ) unless $self -> send_stop ; } sub status { my $self = shift ; $self -> dmon -> Status ( undef ) ; } sub sss_exit { my $self = shift ; my $ARG = shift ; if ( $ARG and $ARG eq 'start' ) { my ( $pid, $msg ) = $self -> start_daemon ; if ( $pid ) { # can't/won't start logq ( $msg ) ; my $xit = ( $pid == -1 ? 1 : 0 ) ; exit $xit ; } else { # we have a running daemon Util::rotlog ; logd ( "$0 start" ) ; my $sys_lock = $CONF -> sys_lock ; $self -> xlock ; $self -> make_stp ; $MODE = 1 ; $CONF -> sys_lock_make or logq ( "can't write sys_lock [%s] ; nm", $sys_lock ) ; STDOUT -> autoflush ( 1 ) ; STDERR -> autoflush ( 1 ) ; $CONF -> priv_new ; logq ( "daemon started" ) ; } } elsif ( $ARG and $ARG eq 'stop' ) { my $pid = $self -> status ; my $msg = "$PROG: $WHO_IAM is not running" ; my $xit = 0 ; if ( $pid ) { my $cnt = $self -> stop_daemon ; $msg = sprintf "$PROG: %s $WHO_IAM on %s ; pid %s" , ( $cnt ? 'stopped' : "can't stop" ), $HOSTNAME, $pid ; $self -> rm_stp if $cnt ; $xit = ! $cnt ; } logq ( $msg ) ; exit ( $xit || 0 ) ; } elsif ( $ARG and $ARG eq 'state' ) { my $pid = $self -> status ; my $msg = "$PROG: $WHO_IAM is not running" ; if ( $pid ) { $msg = $self -> send_state ; } logt ( $msg ) ; exit 0 ; } elsif ( my $pid = $self -> status ) { logt ( "$PROG: $WHO_IAM is running ; pid %s\n", $pid ) ; exit 0 ; } else { logt ( "$PROG: $WHO_IAM is not running\n" ) ; exit 1 ; } } ############################################################## package Conf ; Util -> import ; our %DEF_CONF_HASH = ( PORT => 2207 , LOGF => "/var/log/$NAME.log" , LOGR => 8 , ALLO => {} , LOGD => "/var/log/$NAME1" , HOST => 'localhost' , RUND => "/var/run/$NAME" , LOCD => "/var/lock/subsys" , SAVE => "/var/log/$NAME-save" , RTRY => 300 , PLST => 60 , MUXT => 10 , MUXC => 5 , RCVT => 900 , NAMS => '*.log' , HOT => 1 , RENF => '/etc/arlogd/renames' , FIFOS => '/var/log/fifos' , USER => undef , GRP => undef , _FILE => "@DEF_CONF_FILES" , _errs => [] , _wrns => [] , _ouid => $> , _ogid => $) , _nuid => undef , _ngid => undef ) ; our %W4K = ( HOST => 'loghost' , LOGD => 'log_dir' , LOGF => 'logfile' , LOGR => 'log_rotate' , ALLO => 'allow_host' , PORT => 'port' , RTRY => 'reconnect' , PLST => 'upd_fifos' , MUXT => 'send_timeout' , MUXC => 'send_connect' , RCVT => 'recv_timeout' , RUND => 'run_dir' , LOCD => 'lock_dir' , SAVE => 'save_dir' , NAMS => 'log_names' , HOT => 'autoflush' , RENF => 'rename_list' , USER => 'user' , GRP => 'group' , FIFOS => 'fifos' , _FILE => 'config_file' , _errs => '_errors' , _wrns => '_warnings' , _ouid => 'old_uid' , _ogid => 'old_gid' , _nuid => 'new_uid' , _ngid => 'new_gid' ) ; our %K4W = () ; for ( keys %W4K ) { my $val = $W4K { $_ } ; $K4W { $val } = $_ unless ref $val ; } our @UNDEF_OK = qw(user group) ; our %UNDEF_OK ; $UNDEF_OK { $_ } ++ for @UNDEF_OK ; sub FILES { $DEF_CONF_HASH { _FILE } ; } sub _val ($) { my $self = shift ; my $key = shift ; warn "_val no key [$key]" unless exists $self -> { $key } ; $self -> { $key } ; } for my $tag ( keys %W4K ) { my $sub = "sub $tag { \$_[0] -> _val ( '$tag' ) ; }" ; eval $sub ; die $@ if $@ ; } for my $tag ( grep ! ref ( $_ ), values %W4K ) { my $sub = "sub $tag { \$_[0] -> _val ( \$K4W { $tag } ) ; }" ; eval $sub ; die $@ if $@ ; } sub _add_xxx { my $self = shift ; my $lst = $self -> { shift @_ } ; my $fmt = shift ; push @$lst, sprintf $fmt, @_ ; } sub _add_err { my $self = shift ; $self -> _add_xxx ( '_errs', @_ ) ; } sub _add_wrn { my $self = shift ; $self -> _add_xxx ( '_wrns', @_ ) ; } sub _pref_xxxx { my $self = shift ; my $pref = shift ; my $list = shift ; for ( @{ $self -> $list } ) { $_ = "$pref$_" ; } } sub _pref_errs { _pref_xxxx @_, '_errs' ; } sub _pref_wrns { _pref_xxxx @_, '_wrns' ; } sub _pref_all { _pref_errs @_ ; _pref_wrns @_ ; } sub cnt_errors { scalar @{ $_[0] -> _errs } ; } sub cnt_warngs { scalar @{ $_[0] -> _wrns } ; } sub cnt_all { cnt_errors ( $_[0] ) + cnt_warngs ( $_[0] ) ; } sub _def ($) { my $x = shift ; defined ( $x ) ? $x : '' ; } sub new { bless {}, shift ; } sub Init { my $self = shift ; my %opts = @_ ; for ( keys %DEF_CONF_HASH ) { my $val = $DEF_CONF_HASH { $_ } ; $self -> { $_ } = ( ( 'ARRAY' eq ref $val ) ? [ @$val ] : ( ( 'HASH' eq ref $val ) ? { %$val } : $DEF_CONF_HASH { $_ } ) ) ; } $self ; } sub Make { my $self = shift ; my $res = $self -> new -> Init ( @_ ) ; $res ; } sub set_glob { my $self = shift ; $CONF = $self ; } sub get { my $self = shift ; my $file = shift ; my @FILE = () ; my $FILE = undef ; return $self if $self -> cnt_errors ; if ( defined $file ) { unless ( -e $file ) { $self ->_add_err ( "can't find config file [$file]" ) ; } elsif ( ! open FILE, $file ) { $self ->_add_err ( "can't open config file [$file]" ) ; } else { @FILE = ; close FILE ; $FILE = $file ; } } else { my @files = split ' ', $self -> FILES ; for my $f ( @files ) { if ( open FILE, $f ) { @FILE = ; $FILE = $f ; close FILE ; last ; } } $self -> _add_err ( "can't open any default config files" ) unless $FILE ; } unless ( defined $FILE ) { $FILE = '' ; # $_ .= " ; using defaults" for @{ $self -> _errs } ; } $self -> { _FILE } = $FILE ; for my $line ( @FILE ) { chomp $line ; next if $line =~ /^#/ ; next if $line =~ /^\s*$/ ; my ( $word, $val ) = split ' ', $line, 2 ; my $key = $K4W { $word } ; my $use = 0 ; logd ( "conf word[$word] key[%s] val[%s]\n", _def $key, _def $val ) ; if ( $word eq 'FATAL' ) { $self -> _add_err ( "simulated FATAL error in $FILE" ) ; } if ( ! exists $K4W { $word } ) { $self -> _add_wrn ( "bad key '$word' in $FILE" ) ; } elsif ( ! $UNDEF_OK { $word } and ! defined $val ) { $self -> _add_wrn ( "no value for key '$word' in $FILE" ) ; } elsif ( $word eq 'autoflush' and $val !~ /^[01]$/ ) { $self -> _add_wrn ( "value for '$word' should be 0 or 1" ) ; } elsif ( $word eq 'send_timeout' and $val !~ /^\d+$/ ) { $self -> _add_err ( "value for '$word' must be a number" ) ; } else { if ( 'HASH' eq ref ( $self -> { $key } ) ) { my ( $k, $v ) = split ' ', $val ; $v ||= '' ; $self -> { $key } { $k } = $v ; } else { $self -> { $key } = $val ; } } } for my $key ( qw(RUND LOGD) ) { my $val = $self -> { $key } ; $val =~ s!//+!/!g ; $val =~ s!/+$!!g ; $self -> { $key } = $val ; } $self -> _pref_all ( '[config] ' ) ; $self ; } sub checks { my $self = shift ; my $t = '[check]' ; ### test logging my $LOGF = $self -> LOGF ; my $HOST = $self -> HOST ; if ( open LOGF, '>>', $LOGF ) { close LOGF ; } else { my $tmp = "/tmp/arlogd.log.$$" ; $self -> _add_wrn ( "$t can't log to $LOGF ($!)" ) ; $self -> { LOGF } = $tmp ; $self -> _add_wrn ( "... logging to $tmp" ) ; } ### check value for log_rotate my $LOGR = $self -> LOGR ; unless ( $LOGR =~ /^\d+$/ ) { $self -> _add_wrn ( "value for %s [%s] isn't a number ; set to 0" , $W4K{LOGR}, $LOGR ) ; $self -> LOGR ( 0 ) ; } ### check for default ALLO and HOST if ( $WHO_IAM eq 'server' and 0 == scalar keys %{ $self -> { ALLO } } ) { $self -> { ALLO } { $DEF_ALLOW_HOST } = '' ; $self -> _add_wrn ( "using default $W4K{ALLO} ($DEF_ALLOW_HOST)" ) } if ( $WHO_IAM eq 'client' and $HOST eq $DEF_CONF_HASH { HOST } ) { $self -> _add_wrn ( "using default $W4K{HOST} ($HOST)" ) } ### check resolv my @bads = grep { ! defined Util::get_host_ips ( $_ ) ; } ( $WHO_IAM eq 'server' ? keys %{ $self -> { ALLO } } : $HOST ) ; $self -> _add_wrn ( "$t can't resolve [%s]\n", join ', ', @bads ) if @bads ; ### user and group my ( $UID, $GID ) ; if ( defined $self -> { USER } ) { my $usr = $self -> { USER } ; my $uid = ( ( $usr =~ /^\d+$/ ) ? getpwuid $usr : getpwnam $usr ) ; unless ( defined $uid ) { $self -> _add_err ( "can't find user [$usr]" ) ; } elsif ( $< and $uid != $< ) { $self -> _add_err ( "you must be root to run as [$usr]" ) ; } else { $UID = $uid ; } } if ( defined $self -> { GRP } ) { my $grp = $self -> { GRP } ; my $me = getpwuid ( $< ) || $< ; my $gid = ( ( $grp =~ /^\d+$/ ) ? getgrgid $grp : getgrnam $grp ) ; unless ( defined $gid ) { $self -> _add_err ( "can't find group [$grp]" ) ; } elsif ( $< and ! grep $_ eq $gid, split ' ', $( ) { $self -> _add_err ( "$me not in group [$grp]" ) ; } else { $GID = $gid ; } } if ( defined $GID ) { if ( $< ) { $self -> _add_wrn ( "not root ; ignore config 'group'" ) ; } else { my $grps = join ' ', grep $_ ne $GID, split ' ', $) ; my $ngid = sprintf "%s %s", $GID , ( $grps || $GID ) ; $self -> { _ngid } = $ngid ; $self -> _add_wrn ( "new \$) [$ngid]" ) ; } } if ( defined $UID ) { if ( $< ) { $self -> _add_wrn ( "not root ; ignore config 'user'" ) ; } else { $self -> { _nuid } = $UID ; } } if ( $WHO_IAM eq 'server' ) { my $fil = sprintf "%s/%s", $CONF -> LOGD, "tst-$$" ; $self -> priv_new ; if ( open TST, '>', $fil ) { close TST ; unlink $fil ; } else { $self -> _add_err ( "can't create [$fil] ($!)" ) ; } $self -> priv_old ; } } sub priv_new { my $self = shift ; if ( $PRIV eq 'old' ) { if ( defined $self -> { _ngid } ) { my $gid = $self -> { _ngid } ; $) = $gid ; } if ( defined $self -> { _nuid } ) { my $uid = $self -> { _nuid } ; $> = $uid ; } } $PRIV = 'new' ; } sub priv_old { my $self = shift ; if ( $PRIV eq 'new' ) { $) = $self -> { _ouid } ; $> = $self -> { _ogid } ; } $PRIV = 'old' ; } sub exit_on_errors { my $self = shift ; my $ARG = shift ; my $errs = $self -> _errs ; my $wrns = $self -> _wrns ; $self -> _pref_errs ( 'error: ' ) ; $self -> _pref_wrns ( 'warning: ' ) ; logt ( $_ ) for @$wrns ; logq ( $_ ) for @$errs ; logq ( "$PROG was NOT %s'ed", $ARG ) if @$errs and $ARG =~ /^(stop|start)$/ ; exit 1 if @$errs ; } sub make_path { my $self = shift ; my $tst = shift ; my $tag = shift ; my $mod = 0755 ; my $dir = $self -> { $tag } ; my $msg = $W4K { $tag } ; my $t = '[check]' ; die "no dir for make_path[$tag]" unless defined $dir ; use File::Path qw(mkpath) ; unless ( -d $dir ) { my @dirs = eval { mkpath $dir, 0, $mod ; } ; if ( $@ ) { $self -> _add_err ( "$t can’t mkdir $msg [$dir] ($!)" ) ; } elsif ( ! $tst ) { $self -> _add_wrn ( "$t did mkdir $msg [$dir]" ) ; } if ( $tst ) { rmdir for reverse @dirs ; } } } sub make_paths { my $self = shift ; my $test = shift ; return if $self -> cnt_errors ; my @tags = @_ ; for my $tag ( @tags ) { $self -> make_path ( $test, $tag ) ; } } sub def_conf { Conf -> Make -> _dmp ( "default config" ) ; } sub def_conf_files { join ' or ', split ' ', Conf -> FILES ; } sub xxx_file { my $self = shift ; my $xxx = shift ; my $type = shift || $WHO_IAM ; "$self->{RUND}/$type.$xxx" ; } sub pid_file { my $self = shift ; $self -> xxx_file ( 'pid', @_ ) ; } sub lck_file { my $self = shift ; $self -> xxx_file ( 'lck', @_ ) ; } sub stp_file { my $self = shift ; $self -> xxx_file ( 'stp', @_ ) ; } sub stt_file { my $self = shift ; $self -> xxx_file ( $STAT, @_ ) ; } sub sys_lock { my $self = shift ; sprintf "%s/%s-%s", $self -> LOCD, $NAME, $WHO_IAM ; } sub sys_lock_make { my $res = 0 ; if ( open SYSLOCK, ">>", $_[0] -> sys_lock ) { close SYSLOCK ; $res = 1 ; } $res ; } sub sys_lock_rm { unlink $_[0] -> sys_lock ; } sub _dmp { my $self = shift ; my $head = shift ; my @res = ( "$head :" ) ; my $W = 0 ; for my $wrd ( keys %K4W ) { my $l = length $wrd ; $W = $l if $l > $W ; } for my $key ( sort { $W4K { $a } cmp $W4K { $b } } keys %$self ) { next if $key =~ /^_[a-z]/ ; my $val = $self -> { $key } ; if ( 'ARRAY' eq ref $val ) { $val = ( @$val > 1 ? sprintf ( "\n [ %s\n ]", join "\n , ", @$val ) : ( @$val == 1 ? "[ $val->[0] ]" : '[]' ) ) ; } elsif ( 'HASH' eq ref $val ) { my $siz = scalar keys %$val ; my @val = %$val ; $val = ( $siz > 1 ? sprintf ( "\n { %s\n }", join "\n , " , map { "$_ => '$val->{$_}'" ; } sort keys %$val ) : ( $siz == 1 ? "{ $val[0] => $val[1] }" : '{}' ) ) ; } push @res, sprintf "%-${W}s %s", $W4K { $key } , ( defined $val ? $val : '' ) ; } join "\n", @res ; } sub dmp { my $self = shift ; my $head = shift || "current config" ; printf "%s\n", $self -> _dmp ( $head ) ; } sub make_allow_data { my $self = shift ; my $hosts = $self -> { ALLO } ; my $res = {} ; for my $host ( sort keys %$hosts ) { my $pref = $hosts -> { $host } ; my $ips = Util::get_host_ips ( $host ) ; if ( defined $ips ) { for my $ip ( @$ips ) { $res -> { $ip } = { host => $host, pref => $pref } ; logt ( $host =~ /$IP_PAT/ ? "allow $ip" : "allow $host ($ip)" ) ; } } else { logq ( "can't resolve $host" ) ; } } $ALLOW_DATA = $res ; } sub just_test { my $self = shift ; print "config : no errors found\n\n" ; $self -> dmp ; exit ; } ############################################################## package Thread ; Util -> import ; sub new { my $self = shift ; bless {}, $self ; } sub Make { my $self = shift ; $self -> new -> Init ( @_ ) ; } sub inp { $_[0] -> { inp } = $_[1] if @_ > 1 ; $_[0] -> { inp } ; } sub out { $_[0] -> { out } = $_[1] if @_ > 1 ; $_[0] -> { out } ; } sub binp { $_[0] -> { binp } ; } sub bout { $_[0] -> { bout } ; } sub base { $_[0] -> { base } = $_[1] if @_ > 1 ; $_[0] -> { base } ; } sub ltim { $_[0] -> { ltim } = $_[1] if @_ > 1 ; $_[0] -> { ltim } ; } sub Init { my $self = shift ; $self -> { inp } = shift ; $self -> { out } = shift ; $self -> { binp } = Buff -> Make ( '' ) ; $self -> { bout } = Buff -> Make ( '' ) ; $self -> { base } = undef ; $self -> { ltim } = time ; $self ; } sub do_line { my $self = shift ; my $line = shift ; $line ; } sub pipe_to { my $self = shift ; my $that = shift ; $self -> { bout } = $that -> binp ; $self -> { out } = undef ; $self ; } sub do_lines { my $self = shift ; my $binp = $self -> binp ; my $bout = $self -> bout ; if ( $self -> binp -> length and $binp != $bout ) { my $pos = 0 ; for ( my $idx = $binp -> index ( "\n", $pos ) ; $idx != -1 ; $idx = $binp -> index ( "\n", $pos ) ) { $bout -> add ( $self -> do_line ( $binp -> substr ( $pos, $idx + 1 - $pos ) ) ) ; $pos = $idx + 1 ; } $binp -> del ( $pos ) ; } } sub done { my $self = shift ; my $str = '' ; my $len = $self -> binp -> sysread ( $self -> inp ) ; if ( $len ) { $self -> do_lines ; $self -> ltim ( time ) ; } ! $len ; } sub flush { my $self = shift ; my $tout = shift || 0 ; my $out = $self -> out ; my $str = $self -> bout -> get ; my $err = undef ; my $res = undef ; unless ( $out ) { logt ( "Thread::flush : no out" ) ; return undef ; } my $time = time ; if ( $tout ) { eval { alarm $tout ; $res = syswrite $out, $str ; $err = $! unless defined $res ; alarm 0 ; } ; alarm 0 ; logt ( "flush : eval[$@]" ) if $@ ; } else { $res = syswrite $out, $str ; $err = $! unless defined $res ; } if ( defined $res ) { $self -> bout -> del ( $res ) ; } else { my $ival = time - $time ; logt ( "flush: syswrite returned undef (%s) tout[%s] sec[%s]" , $err, $tout, $ival ) ; } $res ; } sub stop { my $self = shift ; for my $h ( $self -> inp, $self -> out ) { next unless ref ( $h ) ; $h -> flush if $h -> can ( 'flush' ) ; # $h -> close if $h -> can ( 'close' ) ; } } sub Dump { my $self = shift ; logd ( " self : %s\n", $self ) ; logd ( " inp [$self->{inp}]\n" ) ; logd ( " out [$self->{out}]\n" ) ; logd ( " binp [%d] %s\n", $self -> binp -> length, $self -> binp ) ; logd ( " bout [%d] %s\n", $self -> bout -> length, $self -> bout ) ; } sub STATE { my $self = shift ; [ "sock $self" , join "\n", ( sprintf ( "self %s" , $self ) , sprintf ( " inp [%s]" , $self->{inp} ) , sprintf ( " out [%s]" , $self->{out} ) , sprintf ( " binp [%d]", $self -> binp -> length ) , sprintf ( " bout [%d]", $self -> bout -> length ) ) ] ; } sub state_buffs { my $self = shift ; my $res = [] ; for my $tag ( qw(binp bout) ) { my $buff = $self -> { $tag } ; push @$res, $buff ? $buff -> state ( $tag ) : "no $tag" ; } $res ; } ############################################################## package Thread::Service ; use IO::Socket::INET ; Util -> import ; @Thread::Service::ISA = qw(Thread) ; sub Init { my $self = shift ; my $port = $self -> { port } = shift ; $self -> { pack } = shift ; $self -> { alws } = shift ; $self -> { args } = [ @_ ] ; my $sock = $self -> { sock } = new IO::Socket::INET ( Listen => 10 , LocalPort => $port, ReuseAddr => 1 ) ; die "Could not create socket for $port ($!)\n" unless $self -> sock ; $sock -> shutdown ( 1 ) ; # no writes $self -> Thread::Init ( $sock, $sock ) ; } sub port { $_[0] -> { port } ; } sub pack { $_[0] -> { pack } ; } sub sock { $_[0] -> { sock } ; } sub alws { $_[0] -> { alws } ; } sub args { $_[0] -> { args } ; } sub allow { my $self = shift ; exists $self -> alws -> { $_[0] } ; } sub done { my $self = shift ; my $base = shift ; my $sock = $self -> sock -> accept () ; my $peer = $sock -> peerhost () ; my $port = $sock -> peerport () ; my $pack = $self -> pack ; my $args = $self -> args || [] ; my $res = 0 ; if ( $self -> allow ( $peer ) ) { my $thrd = $pack -> Make ( $sock, @$args ) ; $base -> Add ( $thrd ) ; logt ( "connection on port $self->{port} from [$peer:$port]" ) ; } else { close $sock ; logt ( "peer $peer not allowed on $self->{port}") ; } 0 ; } sub STATE { my $self = shift ; [ "service $self", sprintf "listening on port %s", $self -> port ] ; } ############################################################## package Thread::Service::Meta ; @Thread::Service::Meta::ISA = qw(Thread::Service) ; sub Init { my $self = shift ; my $port = shift ; my $pack = shift ; my @args = @_ ; $self -> Thread::Service::Init ( $port, $pack, $ALLOW_META, @args ) ; } ############################################################## package Thread::Service::Data ; @Thread::Service::Data::ISA = qw(Thread::Service) ; sub Init { my $self = shift ; my $port = shift ; my $pack = shift ; my @args = @_ ; $self -> Thread::Service::Init ( $port, $pack, $ALLOW_DATA, @args ) ; } ############################################################## package Thread::Meta ; Util -> import ; @Thread::Meta::ISA = qw(Thread) ; sub Init { my $self = shift ; my $sock = shift ; $self -> Thread::Init ( $sock, $sock ) ; $self ; } sub do_line { my $self = shift ; my $line = shift ; chomp $line ; $line =~ /^(\w+\??)\s*/ ; my $cmd = $1 || 'empty' ; my $arg = $' || '' ; my $res = '' ; { ( my $msg = $cmd ) =~ s/$STPR\s*//g ; logt ( "COMMAND $msg" ) ; } if ( $cmd eq 'PING' ) { $res = 'PONG' ; } elsif ( $cmd eq 'STATE' ) { $res = $self -> base -> STATE ; } elsif ( $cmd eq 'STOP' ) { $res = ( ( $arg eq $STPR ) ? $self -> STOP : 'BAD SECRET' ) ; } else { $res = $self -> command ( $cmd, $arg ) ; } $res = "unknown command [$line]" unless defined $res ; "COMMAND $cmd\n$res\n" ; } sub STOP { my $self = shift ; $self -> bout -> add ( 'STOPPED' ) ; logd ( 'stopping ; self flush' ) ; $self -> flush ; logd ( 'stopping ; self shutdown' ) ; $self -> out -> shutdown ( 2 ) ; # done using logd ( 'stopping ; base stop' ) ; $self -> base -> stop ; logd ( 'stopping ; base stop done' ) ; $STOP = 'clean' ; exit ; } sub STATE { my $self = shift ; my $sock = $self -> inp ; [ "serving $self" , sprintf "processing a command-session from %s port %s" , $sock -> peerhost, $sock -> sockport ] ; } ############################################################## package Thread::Meta::Server ; Util -> import ; @Thread::Meta::Server::ISA = qw(Thread::Meta) ; sub Init { my $self = shift ; my $sock = shift ; $self -> { dmux } = shift ; $self -> Thread::Meta::Init ( $sock ) ; $self ; } sub command { my $self = shift ; my $cmd = shift ; my $arg = shift ; my $dmux = $self -> { dmux } ; my $mesg = "unknown command [$cmd]" ; if ( $cmd =~ /^(NO_)?AUTOFLUSH$/ ) { $dmux -> close_logs ; my $was = $CONF -> { HOT } ; my $HOT = $CONF -> { HOT } = ( $cmd =~ /^AUTO/ ? 1 : 0 ) ; $mesg = "AUTOFLUSH $was -> $HOT" ; } elsif ( $cmd eq 'AUTOFLUSH?' ) { my $HOT = $CONF -> { HOT } ; $mesg = "AUTOFLUSH $HOT" ; } elsif ( $cmd eq 'CLOSE' ) { $mesg = $dmux -> close_logs ; } elsif ( $cmd eq 'FIND' ) { $arg ||= $CONF -> { NAMS } ; $mesg = $dmux -> find_logs ( $arg ) ; } elsif ( $cmd eq 'RENAME' ) { $mesg = $dmux -> rename_logs ; } elsif ( $cmd eq 'ROTATE' ) { $arg ||= $CONF -> { NAMS } ; $mesg = $dmux -> rotate_logs ( $arg ) ; } else { $mesg = undef ; } $mesg ; } ############################################################## package Thread::Meta::Client ; Util -> import ; @Thread::Meta::Client::ISA = qw(Thread::Meta) ; sub command { my $self = shift ; my $cmd = shift ; my $arg = shift ; my $mesg = undef ; $mesg ; } ############################################################## package Thread::Data ; Util -> import ; @Thread::Data::ISA = qw(Thread) ; sub Init { my $self = shift ; my $sock = shift ; $self -> Thread::Init ( $sock, $sock ) ; $self ; } ############################################################## package Thread::Data::Server ; Util -> import ; @Thread::Data::Server::ISA = qw(Thread::Data) ; sub Init { my $self = shift ; my $sock = shift ; my $dmux = shift ; my $peer = $self -> { peer } = $sock -> peerhost ; my $port = $self -> { port } = $sock -> peerport ; $sock -> shutdown ( 1 ) ; # no writes $self -> Thread::Data::Init ( $sock ) ; $self -> pipe_to ( $dmux ) ; $self ; } sub do_line { my $self = shift ; my $line = shift ; sprintf "%s %s", $self -> peer, $line ; } sub peer { my $self = shift ; $self -> { peer } ; } sub port { my $self = shift ; $self -> { port } ; } sub inactive { my $self = shift ; time - $self -> ltim > $CONF -> RCVT ; } sub STATE { my $self = shift ; my $sock = $self -> inp ; my $peer = $sock -> peerhost || '' ; my $port = $sock -> sockport || '' ; my $wait = time - $self -> ltim ; [ "data $self" , ( sprintf "collecting data from %s:%s sock [%s:%s] waiting %s" , $self -> peer, $self -> port, $peer, $port, $wait ) , @{ $self -> state_buffs } ] } ############################################################## package Files ; Util -> import ; use File::Path qw(mkpath) ; use IO::File ; sub new { my $self = shift ; bless {}, $self ; } sub Make { my $self = shift ; $self -> new -> Init ( @_ ) ; } our $BAD = 'BAD_FILE.log' ; sub Init { my $self = shift ; $self -> { fhs } = {} ; $self -> { bad } = {} ; $self ; } sub have { my $self = shift ; my $pref = shift ; $self -> { fhs } { $pref } ; } sub bad { my $self = shift ; my $pref = shift ; $self -> { bad } { $pref } ; } sub fh { my $self = shift ; my $pref = shift ; if ( @_ ) { my $fh = shift ; $self -> { fhs } { $pref } = $fh ; } $self -> { fhs } { $pref } ; } our %cache_pp = () ; sub peer_pref { my $peer = shift ; my $pref = shift ; my $res = $cache_pp { $peer } { $pref } ; unless ( defined $res ) { my $pprf = $ALLOW_DATA -> { $peer } { pref } ; $res = $cache_pp { $peer } { $pref } = ( $pprf ? "$pprf$pref" : $pref ) ; } $res ; } sub print { my $self = shift ; my $line = shift ; my ( $peer, $pref, $entry ) = split ' ', $line, 3 ; $pref = $cache_pp { $peer } { $pref } || peer_pref $peer, $pref ; my $fh = $self -> fh ( $pref ) || $self -> open_log ( $pref ) ; # $fh may be undefined if open_log($pref) failed if ( $fh ) { if ( $self -> bad ( $pref ) ) { $fh -> print ( $line ) ; } else { $fh -> print ( $entry ) ; } } '' ; } sub open_log ; sub open_log { my $self = shift ; my $pref = shift ; if ( Util::bad_pref ( $pref ) ) { logt ( "bad prefix [%s] ; using %s", $pref, $BAD ) ; unless ( defined $self -> fh ( $BAD ) ) { my $fh = $self -> open_log ( $BAD ) ; $self -> fh ( $pref, $fh ) ; } $self -> { bad } { $pref } ++ ; $self -> fh ( $pref, $self -> fh ( $BAD ) ) ; } else { my $path = $CONF -> LOGD . "/$pref" ; my $dir = Util::dirname ( $path ) ; eval { mkpath $dir } unless -d $dir ; logt ( "can’t mkpath [$dir] ($@)" ) if $@ ; if ( -d $dir ) { my $fh = IO::File -> new ( $path, '>>' ) ; if ( $fh ) { $fh -> autoflush ( $CONF -> HOT ) ; } else { logt ( "can't append log $path" ) ; } $self -> fh ( $pref, $fh ) ; logv ( "open %s", $path ) ; } else { logt ( "can't find or make $dir" ) ; } } $self -> fh ( $pref ) ; } sub close_logs { my $self = shift ; my $fhs = $self -> { fhs } ; logt ( "closing logs" ) ; my @res = () ; for my $pref ( sort keys %$fhs ) { my $fh = $self -> fh ( $pref ) ; if ( $fh and defined ( $fh -> fileno ) ) { my $bad = $self -> { bad } { $pref } ; my $msg = $bad ? "bad[$pref] -> $BAD" : $pref ; logt ( "closed $msg" ) ; push @res, "FILE: $msg" ; $fhs -> { $pref } -> close ; } } $self -> { fhs } = {} ; $self -> { bad } = {} ; unshift @res, sprintf "FILES %d", scalar @res ; join "\n", @res ; } sub state { my $self = shift ; my $fhs = $self -> { fhs } ; my @res = () ; for my $pref ( sort keys %$fhs ) { my $def = defined ( $self -> { fhs } { $pref } ) ; my $bad = defined ( $self -> { bad } { $pref } ) ; push @res, sprintf "%s : %s" , ( $def ? 'opened' : 'closed' ) , ( $bad ? "bad[$pref] -> $BAD" : $pref ) ; } @res ? map { " $_" } @res : ' no open files' ; } ############################################################## package Thread::Dmux ; Util -> import ; @Thread::Dmux::ISA = qw(Thread) ; use File::Path qw(mkpath) ; use IO::File ; sub Init { my $self = shift ; $self -> Thread::Init ( undef, undef ) ; $self -> { fhs } = Files -> Make ; $self ; } sub do_line { my $self = shift ; my $line = shift ; $self -> fhs -> print ( $line ) ; '' ; } sub fhs { my $self = shift ; $self -> { fhs } ; } sub close_logs { my $self = shift ; $self -> fhs -> close_logs ; } sub mk_re { my $pat = shift ; $pat =~ s/^\s*// ; $pat =~ s/\s*$// ; $pat =~ s/\./\\./g ; $pat =~ s/\*/[^\/]*/g ; $pat .= '$' ; my $re = eval { qr{$pat} ; } ; ( $re, $pat ) ; } our $find_re = sub { my $x = shift ; my $re = shift ; -f $x and $x =~ $re ; } ; sub find_logs { my $self = shift ; my $pat = shift ; my ( $re, $p ) = mk_re $pat ; my $LOGD = $CONF -> LOGD ; my @res = () ; logd ( "find_logs [$pat] -> /$p/" ) ; if ( defined $re ) { @res = map "FILE: $_", Util::find ( $LOGD , $find_re , $re ) ; unshift @res, sprintf "FILES %d", scalar @res ; } else { push @res , "ERROR bad pattern [$pat]" ; } join "\n", @res ; } sub rename_logs { my $self = shift ; my $lst = $CONF -> rename_list ; my $dir = $CONF -> log_dir ; my $me = scalar getpwuid $< ; my ( $mod, $uid ) = ( stat $lst ) [ 2, 4 ] ; my $nok = ( ( defined $mod ) ? ( $mod & 022 ? sprintf ( 'bad mode [%o] for %s', 0777 & $mod, $lst ) : '' ) : "can't stat [$lst]" ) ; logt ( "rename [$lst]" ) ; if ( ! defined $me ) { return "ERROR can't getpwuid for me [$<]" ; } elsif ( $uid != $< ) { return "ERROR I ($me) don't own $lst" ; } elsif ( $nok ) { return "ERROR $nok" ; } elsif ( ! open LST, $lst ) { return "ERROR can't read $lst ($!)" ; } elsif ( ! -d $dir ) { return "ERROR can't find log_dir $dir ($!)" ; } $self -> close_logs ; my @res = () ; my @wrn = () ; for my $line ( ) { chomp $line ; next if $line =~ /^#/ ; next if $line =~ /^\s*$/ ; $line =~ s/^\s*// ; $line =~ s/\s*$// ; unless ( $line =~ /^mv\s+(\S+)\s+(\S+)\s*/ ) { push @res, "ERROR bad line [$line]" ; } else { my $src = "$dir/$1" ; my $dst = $2 ; if ( -l $src ) { push @res, "ERROR won't move a symlink $src ($!)" } elsif ( -d $src ) { push @res, "ERROR won't move a directory $src ($!)" } elsif ( -l $dst ) { push @res, "ERROR won't move to symlink $dst ($!)" } elsif ( -d $dst ) { push @res, "ERROR won't move to directory $dst ($!)" } elsif ( -e $dst and ! unlink $dst ) { push @res, "ERROR can't unlink $dst ($!)" } elsif ( ! -f $src ) { push @wrn, "WARN: can't find $src" ; if ( open DST, ">", $dst ) { close DST ; push @res, "DONE: EMPTY $dst" ; } else { push @res, "ERROR can't create empty $dst ($!)" ; } } elsif ( ! rename $src, $dst ) { push @res, "ERROR can't rename $src $dst ($!)" } else { push @res, "DONE: $src $dst" } } } unshift @res, sprintf "FILES %d", scalar @res ; unshift @res, sprintf "FILE: %s", $lst ; join "\n", @wrn, @res ; } sub rotate_logs { my $self = shift ; my $pat = shift ; my ( $re, $p ) = mk_re $pat ; my $LOGD = $CONF -> LOGD ; my @res = () ; logt ( "rotate_logs [$pat] -> /$p/" ) ; unless ( defined $re ) { logt ( "bad pattern [$pat]" ) ; return "FILES 0\nERROR bad pattern[$pat]" ; } $self -> close_logs ; for my $src ( Util::find ( $LOGD, $find_re , $re ) ) { my $dst = "$src.$ROT" ; unlink $dst ; # ignore errors if ( rename $src, $dst ) { logt ( "rename [$src] [$dst]" ) ; push @res, "FILE: $src" ; } else { logt ( "can't rename [$src] [$dst]" ) ; push @res, "ERROR can't rename $src ($!)" ; } } unshift @res, sprintf "FILES %d", scalar @res ; join "\n", @res ; } sub STATE { my $self = shift ; [ "data $self" , sprintf ( "dmux logdir %s", $CONF -> LOGD ) , $self -> fhs -> state , @{ $self -> state_buffs } ] ; } ############################################################## package Thread::Data::Pipe ; Util -> import ; @Thread::Data::Pipe::ISA = qw(Thread::Data) ; our %logged_bad = () ; sub pref4path { substr $_[0], 1 + length $CONF -> FIFOS ; } sub new { my $self = shift ; bless {}, $self ; } sub Init { my $self = shift ; my $path = shift ; my $pref = pref4path $path ; $self -> { path } = $path ; $self -> { pref } = $pref ; if ( $pref =~ /\s/ ) { logt ( "bad pref [%s]", $pref ) ; $logged_bad { $path } ++ unless $logged_bad { $path } ; $self -> { bad } = 1 ; } my $hndl = $self -> open ; ( $hndl ? $self -> Thread::Init ( $hndl, undef ) : undef ) ; } sub do_line { my $self = shift ; my $line = shift ; my $pref = $self -> pref ; sprintf "%s %s", $pref, $line ; } sub path { my $self = shift ; $self -> { path } ; } sub hndl { my $self = shift ; $self -> { hndl } ; } sub pref { my $self = shift ; $self -> { pref } ; } sub bad { my $self = shift ; $self -> { bad } ; } sub open { my $self = shift ; my $path = $self -> path ; my $hndl = $self -> { hndl } = IO::File -> new ( $path, '+<' ) ; logt ( "can't open fifo [$path] ($!)" ) unless $hndl ; $hndl ; } sub close { my $self = shift ; my $hndl = $self -> hndl ; undef $hndl if $hndl ; } sub STATE { my $self = shift ; my $hash = shift ; my $path = $self -> path ; [ "path $path" , sprintf ( "watching fifo [%s] $path", ( $self -> bad ? 'bad' : 'ok ' ) ) , @{ $self -> state_buffs } ] ; } ############################################################## package Thread::Data::Mux ; Util -> import ; @Thread::Data::Mux::ISA = qw(Thread::Data) ; sub Init { my $self = shift ; $self -> { host } = shift ; $self -> Thread::Init ( undef, undef ) ; $self -> { binp } = $self -> { bout } ; $self -> state ( '' ) ; $self -> hndl ( undef ) ; $self -> sock ( undef ) ; $self -> start ; $self ; } sub host { my $self = shift ; $self -> { host } ; } sub file { my $self = shift ; "$CONF->{SAVE}/$self->{host}.log" ; } sub state { $_[0] -> { state } = $_[1] if @_ > 1 ; $_[0] -> { state } ; } sub hndl { $_[0] -> { hndl } = $_[1] if @_ > 1 ; $_[0] -> { hndl } ; } sub sock { $_[0] -> { sock } = $_[1] if @_ > 1 ; $_[0] -> { sock } ; } sub on_sock { $_[0] -> state eq 'on_sock' ; } sub on_file { $_[0] -> state eq 'on_file' ; } sub retry { my $self = shift ; if ( $self -> open_sock ) { $self -> state ( 'on_sock' ) ; $self -> out ( $self -> sock ) ; $self -> close_file ; $self -> buff_temp_to_sock ; $self -> flush ; } } sub start { my $self = shift ; my $res = 1 ; if ( $self -> open_sock ) { $self -> state ( 'on_sock' ) ; $self -> out ( $self -> sock ) ; $self -> buff_temp_to_sock ; } elsif ( $self -> open_file ) { $self -> state ( 'on_file' ) ; $self -> out ( $self -> hndl ) ; } else { $res = 0 ; } $res ; } sub flush { my $self = shift ; unless ( $self -> state or $self -> start ) { logt ( "can't open sock or file ; empty bout" ) ; $self -> bout -> set ( '' ) ; return ; } my $res = $self -> Thread::flush ( $CONF -> MUXT ) ; if ( ! defined $res ) { logt ( "mux flush failed" ) ; if ( $self -> on_sock ) { my $sock = $self -> sock ; my $shst = $sock -> sockhost || '' ; my $sprt = $sock -> sockport || '' ; my $phst = $sock -> peerhost || '' ; my $pprt = $sock -> peerport || '' ; logt ( "on_sock flush failed ; close [%s:%s] -> [%s:%s]" , $shst, $sprt, $phst, $pprt ) ; my $shut = $sock -> shutdown ( 2 ) ; logt ( "shutdown returned [$shut] ($!)" ) if $shut ; my $clos = $sock -> close ; logt ( "close returned [$clos] ($!)" ) if $clos ; $self -> out ( undef ) ; if ( ! $self -> start ) { logt ( "start failed" ) ; } } elsif ( $self -> on_file ) { logt ( "self is on_file" ) ; } else { logt ( "self is not on_sock or on_file" ) ; } } } our $_open_sock = 0 ; sub open_sock { my $self = shift ; my $res ; eval { alarm $CONF -> MUXC ; $res = IO::Socket::INET -> new ( PeerAddr => $self -> host , PeerPort => $CONF -> PORT , Proto => 'tcp' ) ; alarm 0 ; } ; if ( $@ and $@ =~ /timed out/i ) { logt ( "open socket timeout" ) ; } elsif ( $@ ) { logq ( "Error: bad open_sock timeout eval ($@)" ) ; } alarm 0 ; if ( $res ) { # no reading ... $res -> shutdown ( 0 ) ; logt ( "connected to %s:%s", $self -> host, $CONF -> PORT ) ; $_open_sock = 0 ; } else { logt ( "can't connect to %s:%s", $self -> host, $CONF -> PORT ) unless $_open_sock ++ ; } $self -> sock ( $res ) ; } sub open_file { my $self = shift ; my $NULL = '/dev/null' ; my $res = IO::File -> new ( $self -> file, '>>' ) ; if ( $res ) { $res -> autoflush () ; logt ( "to_file %s", $self -> file ) ; } elsif ( $res = IO::File -> new ( $NULL, '>' ) ) { $res -> autoflush () ; logt ( "to_file %s", $NULL ) ; } else { logq ( "can't append %s", $self -> file ) ; } $self -> hndl ( $res ) ; } sub close_file { my $self = shift ; $self -> hndl -> close if $self -> hndl ; } # resturns 0 if print $sock fails sub buff_temp_to_sock { my $self = shift ; my $sock = $self -> out ; my $file = $self -> file ; my $tmp = "$file.tmp" ; my $cnt = 0 ; # ignore errors unlink $tmp ; if ( rename $file, $tmp and open TMP, $tmp ) { while ( ) { $self -> bout -> add ( $_ ) ; $cnt ++ ; } close TMP ; } logt ( "buffed $cnt lines" ) if $cnt ; 1 ; } sub STATE { my $self = shift ; my $file = $self -> file ; my $out = $self -> out ; [ "mux $self" , ( sprintf "mux writing to %s" , ( ref ( $out ) =~ /Socket/ ? sprintf "%s:%s", $out -> peerhost, $out -> peerport : ( ref ( $out ) =~ /IO::File/ ? $file : ( ( defined $out ) ? $out : '' ) ) ) ) , @{ $self -> state_buffs } ] ; } ############################################################## package Threads ; Util -> import ; sub new { my $self = shift ; bless {}, $self ; } sub Make { my $self = shift ; $self -> new -> Init ( @_ ) ; } sub Init { my $self = shift ; $self -> { list } = {} ; $self -> { inps } = {} ; $self -> { outs } = {} ; $self ; } sub list { $_[0] -> { list } ; } sub inps { $_[0] -> { inps } ; } sub outs { $_[0] -> { outs } ; } sub _close { my $sock = shift ; my $tag = shift ; if ( ref ( $sock ) =~ /Socket/ ) { my $peer = $sock -> peerhost || '' ; my $port = $sock -> sockport || '' ; logt ( "close connection $tag %s:%s", $peer, $port ) ; $sock -> close if $sock and $sock -> can ( 'close' ) ; } } sub Add { my $self = shift ; my $thrd = shift ; my $out = $thrd -> out ; my $inp = $thrd -> inp ; logt ( "Thread::Add $thrd" ) ; logt ( " inp [%s]", $inp ) if $inp ; logt ( " out [%s]", ( ( $inp and $inp == $out ) ? 'same' : $out ) ) if $out ; $thrd -> base ( $self ) ; $self -> list -> { $thrd } = $thrd ; $thrd ; } sub Del { my $self = shift ; my $thrd = shift ; logt ( "Thread::Del $thrd" ) ; my $out = $thrd -> out ; my $inp = $thrd -> inp ; _close $inp, '<-' ; _close $out, '->' ; delete ( $self -> list -> { $thrd } ) ; } sub any_readers { my $self = shift ; my $list = $self -> {list} ; my $res = new IO::Select ; $self -> {inps} = {} ; for my $key ( %$list ) { my $thrd = $list -> { $key } ; my $inp = $thrd -> inp ; next unless $thrd -> binp -> length <= $BUF_SIZE ; next unless $inp and ref ( $inp ) =~ /IO::/ ; $res -> add ( $inp ) ; $self -> {inps} { $inp } = $thrd ; } $res ; } sub any_writers { my $self = shift ; my $list = $self -> {list} ; my $res = new IO::Select ; $self -> {outs} = {} ; for my $key ( %$list ) { my $thrd = $list -> { $key } ; my $out = $thrd -> out ; next unless $thrd -> bout -> length ; next if $thrd -> bout -> index ( "\n" ) == -1 ; next unless $out and ref ( $out ) =~ /IO::/ ; $res -> add ( $out ) ; $self -> {outs} { $out } = $thrd ; } $res ; } sub any_readys { my $self = shift ; my $list = $self -> {list} ; my $res = [] ; for my $key ( keys %$list ) { my $thrd = $list -> { $key } ; next if $thrd -> binp == $thrd -> bout ; next if $thrd -> binp -> index ( "\n" ) == -1 ; push @$res, $thrd ; } $res ; } sub any_inactives { my $self = shift ; [ grep { $_ -> can ( 'inactive' ) and $_ -> inactive } values %{ $self -> list } ] ; } sub by_inp { $_[0] -> {inps} { $_[1] } ; } sub by_out { $_[0] -> {outs} { $_[1] } ; } sub do_a_loop { my $self = shift ; my $rdrs = 0 ; my $wrts = 0 ; my $rdys = 0 ; # if ( $WHO_IAM eq 'client' ) { Arena -> mark ( 'loop', 'start' ) ; } # if ( $WHO_IAM eq 'client' ) { Arena -> mark ( 'read', 'start' ) ; } for my $h ( $self -> any_readers -> can_read ( 3 ) ) { my $thrd = $self -> by_inp ( $h ) ; $self -> Del ( $thrd ) if $thrd -> done ( $self ) ; $rdrs ++ ; } # if ( $WHO_IAM eq 'client' ) { Arena -> diff ( 'read', 'end' ) ; } # if ( $WHO_IAM eq 'client' ) { Arena -> mark ( 'rdys', 'start' ) ; } my $readys = $self -> any_readys ; for my $thrd ( @$readys ) { $thrd -> do_lines ; $rdys ++ ; } # if ( $WHO_IAM eq 'client' ) { Arena -> diff ( 'rdys', 'end' ) ; } # if ( $WHO_IAM eq 'client' ) { Arena -> mark ( 'write', 'start' ) ; } for my $h ( $self -> any_writers -> can_write () ) { $self -> by_out ( $h ) -> flush ; $wrts ++ ; } # if ( $WHO_IAM eq 'client' ) { Arena -> diff ( 'write', 'end' ) ; } # if ( $WHO_IAM eq 'client' ) { Arena -> diff ( 'loop' , 'end' ) ; } sleep 1 unless $rdrs ; } # logt ( "readers[%d] readys[%d] writers[%d]", $rdrs, $rdys, $wrts ) ; sub Dump { my $self = shift ; for my $thrd ( values %{ $self -> {list} } ) { $thrd -> Dump ; } } sub STATE { my $self = shift ; my $LOGF = $CONF -> logfile ; my @list = ( "logfile $LOGF" ) ; for my $tuple ( sort { $a -> [0] cmp $b -> [0] } map { $_ -> STATE } values %{ $self -> {list} } ) { my ( $tag, @itms ) = @$tuple ; push @list, @itms ; } "Daemon $NAME-$WHO_IAM :\n" . join "\n", map { "-- $_" ; } @list ; } sub stop { my $self = shift ; for my $thrd ( values %{ $self -> list } ) { $thrd -> stop ; } } ############################################################## package Pipes ; Util -> import ; sub new { my $self = shift ; bless {}, $self ; } sub Make { my $self = shift ; $self -> new -> Init ( @_ ) ; } sub Init { my $self = shift ; $self -> { by_path } = {} ; $self ; } sub by_path { $_[0] -> { by_path } { $_[1] } ; } sub have { exists $_[0] -> { by_path } { $_[1] } ; } sub add { my $self = shift ; my $path = shift ; my $threads = shift ; my $mux = shift ; my $fifo = Thread::Data::Pipe -> Make ( $path ) ; if ( $fifo ) { $fifo -> pipe_to ( $mux ) ; logt ( "add fifo $path" ) ; $threads -> Add ( $fifo ) ; } $self -> { by_path } { $path } = $fifo ; $fifo ; } sub remove { my $self = shift ; my $path = shift ; my $threads = shift ; my $fifo = $self -> by_path ( $path ) ; logt ( "remove fifo $path" ) ; $threads -> Del ( $fifo ) ; delete $self -> { by_path } { $path } ; } our $is_fifo = sub { my $x = shift ; -p $x and -r $x ; } ; our $_update = 0 ; sub update { my $self = shift ; my $threads = shift ; my $mux = shift ; my $home = $CONF -> FIFOS ; if ( opendir HOME, $home ) { my @paths = Util::find ( $home, $is_fifo ) ; my %paths = () ; $paths { $_ } ++ for @paths ; for my $path ( sort keys %{ $self -> { by_path } } ) { $self -> remove ( $path, $threads ) unless exists $paths { $path } ; } for my $path ( @paths ) { $self -> add ( $path, $threads, $mux ) unless ( $self -> have ( $path ) ) } closedir HOME ; $_update = 0 ; } else { logq ( "can't opendir fifos-home [$home] ($!)" ) unless $_update ++ ; } $self ; } package Buff ; sub new { my $self = shift ; bless { b => '' }, $self ; } sub Init { my $self = shift ; my $s = shift ; $self->{b} = $s ; $self ; } sub Make { my $self = shift ; $self -> new -> Init ( @_ ) ; } sub get { my $self = shift ; $self->{b} ; } sub set { my $self = shift ; my $s = shift ; $self->{b} = $s ; } sub add { my $self = shift ; my $s = shift ; $self->{b} .= $s ; $self ; } sub length { my $self = shift ; length $self->{b} ; } sub index { my $self = shift ; my $str = shift ; my $off = shift || 0 ; index $self->{b}, $str, $off ; } sub substr { my $argc = scalar @_ ; my $self = shift ; my $off = shift ; my $len = shift ; my $rpl = shift ; if ( $argc == 4 ) { die "aap" ; CORE::substr ( $self->{b}, $off, $len, $rpl ) ; } elsif ( $argc == 3 ) { CORE::substr ( $self->{b}, $off, $len ) ; } elsif ( $argc == 2 ) { CORE::substr ( $self->{b}, $off ) ; } } sub del { my $self = shift ; my $len = shift ; $self->{b} = CORE::substr ( $self->{b}, $len ) ; } sub state { my $self = shift ; my $tag = shift ; sprintf " $tag [%s] len [%s]", $self , $self -> length ; } sub sysread { my $self = shift ; my $inp = shift ; sysread $inp, $self->{b}, $BUF_SIZE, CORE::length ( $self->{b} ) ; } 1 ; package Arena ; our $DUMP ; our $done = 0 ; our $ACTV = 0 ; sub Init { my $self = shift ; my $file = shift ; return unless $HAVE_ARENA ; $ACTV = 1 ; open ZZZ, "|./look" ; my $sel = select ZZZ ; $| = 1 ; select $sel ; } sub _report { my $self = shift ; my $cmd = shift ; my $tag = shift ; my $tit = shift || 'no tit' ; return unless $ACTV ; print ZZZ "CMD $cmd $tag $tit\n" ; my $cnts = Devel::Gladiator::arena_ref_counts () ; for my $key ( sort keys %$cnts ) { printf ZZZ "TAB %s %s\n", $key, $cnts -> { $key } ; } print ZZZ "\n" ; } sub mark { my $self = shift ; $self -> _report ( 'MARK', @_ ) ; } sub diff { my $self = shift ; $self -> _report ( 'DIFF', @_ ) ; } END { if ( $ACTV ) { printf ZZZ "quit\n" ; close ZZZ ; } } 1 ; #! /usr/bin/perl package main ; use strict ; use warnings ; use IO::Select ; use IO::Socket ; use IO::Pipe ; use IO::File ; use File::Path qw(mkpath) ; use Net::hostent ; use sigtrap qw(handler sig_handle normal-signals) ; use sigtrap qw(handler sig_handle error-signals) ; BEGIN { Util -> import } ; WHO_IAM ( 'server' ) ; sub sig_handle { logq "exit ; $0 SIG [$!]" ; exit ; } my $prog = substr $0, rindex ( $0, '/' ) + 1 ; $CONF = Conf -> Make -> set_glob ; my %opt = () ; my $ARG = start_up $prog, $CONF, \%opt ; $CONF -> get ( $opt{c} ) -> checks ; $CONF -> make_paths ( $opt{t}, qw(RUND) ) ; $CONF -> priv_new ; $CONF -> make_paths ( $opt{t}, qw(LOGD) ) ; $CONF -> priv_old ; $CONF -> exit_on_errors ( $ARG ) ; $CONF -> just_test if $opt{t} ; Dmon -> Make -> sss_exit ( $ARG ) ; $CONF -> make_allow_data ; my $PORT = $CONF -> PORT ; my $threads = Threads -> Make ; my $dmux = $threads -> Add ( Thread::Dmux -> Make ) ; $threads -> Add ( Thread::Service::Data -> Make ( $PORT, 'Thread::Data::Server', $dmux ) ) ; $threads -> Add ( Thread::Service::Meta -> Make ( $PORT + 1, 'Thread::Meta::Server', $dmux ) ) ; # Arena -> Init ( 'zzz' ) ; # Arena -> mark ( 'server' ) ; my %tab = () ; while ( 1 ) { $threads -> do_a_loop ; for my $thrd ( @{ $threads -> any_inactives } ) { logt ( "delete inactive $thrd" ) ; $threads -> Del ( $thrd ) ; } # Arena -> diff ( 'server' ) ; } END { if ( MODE ) { logq ( STOP eq 'clean' ? "daemon stopped" : "$prog: exits" ) ; $CONF -> sys_lock_rm ; } }