#! /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 <undef>
#     child_STDIN  => '/path/to/daemon/STDIN.file'  -> defautls to '</dev/null'
#     child_STDOUT => '/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 <undef> 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 <open> 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 <chdir> 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 <open> on this kind of device, instead of <sysopen>
            # 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 <wait> 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}  || "</dev/null" )  unless $dont_close_fd{ 0 };
                open( STDOUT, $self->{child_STDOUT} || "+>/dev/null" ) unless $dont_close_fd{ 1 };
                open( STDERR, $self->{child_STDERR} || "+>/dev/null" ) unless $dont_close_fd{ 2 };

                # Since <POSIX::close(FD)> is in some cases "secretly" closing
                # file descriptors without telling it to perl, we need to
                # re<open> and <CORE::close(FH)> as many files as we closed with
                # <POSIX::close(FD)>. 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[ $_ ], "</dev/null" }
                    # Perl will try to close all handles when @fh leaves scope
                    # here, but the rude ones will sacrifice themselves to avoid
                    # potential damage later.
                }


                # Execute a system command and never return.
                if ( $exec_command ) {
                    exec $exec_command;
                    exit; # Not a real exit, but needed since Perl warns you if
                    # there is no statement like <die>, <warn>, or <exit>
                    # following <exec>. The <exec> 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 <wait> for the second child to exit,
            # even if we don't have a value in $exec_command.
            # The second child will become orphan by <exit> here, but then it
            # will be adopted by init(8), which automatically performs a <wait>
            # 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 <open> 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 C<warn>s and returns C<undef>.
################################################################################
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 | <undef>', 'the pid_file | <undef>' )
################################################################################
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 <undef>.
################################################################################
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  = <<USG ;
Usage: $prog [-h] [-s] [-t] [--version] [-c config] [start|stop|state]
USG
    my $HELP = <<HELP ;
option h : print help ; exit
option s : be silent ; use logs instead of stdout
option t : just test and show the config
option c : default @{[Conf->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 = <STOP> ) ; 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 : '<undef>' ; }

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 = <FILE> ; close FILE ; $FILE = $file ; }
      }
    else
      { my @files = split ' ', $self -> FILES ;
        for my $f ( @files )
          { if ( open FILE, $f )
              { @FILE = <FILE> ; $FILE = $f ; close FILE ; last ; }
          }
        $self -> _add_err ( "can't open any default config files" )
          unless $FILE ;
      }
    unless ( defined $FILE )
      { $FILE = '<DEFAULTS>' ;
#       $_ .= " ; 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 : '<undefined>' ) ;
      }
    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 || '<undef>' ;
    my $port = $sock -> sockport || '<undef>' ;
    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 ( <LST> )
      { 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 || '<undef>' ;
            my $sprt = $sock -> sockport || '<undef>' ;
            my $phst = $sock -> peerhost || '<undef>' ;
            my $pprt = $sock -> peerport || '<undef>' ;
            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 ( <TMP> ) 
          { $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 : '<undef>' )
              )
            )
      )
    , @{ $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 || '<undef>' ;
        my $port = $sock -> sockport || '<undef>' ;
        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 ;
      }
  }