#! /usr/bin/perl

use strict ;
use warnings ;

package Dmon ;

use 5.008005 ;
use File::Path ;
use LWP::UserAgent ;
use Digest::MD5 ;
use Carp qw(confess) ;
use DBI ;
use DBD::SQLite 1.17 ;
use JSON::PP ;
use Net::DNS ;
use Net::Ping ;
use IO::Pipe ;
use IO::Select ;
use IO::Socket::INET ;
use Proc::Daemon 0.14 ;
use Time::HiRes ;
use Time::Local ;
use Net::hostent qw(gethost) ;
use Socket qw(inet_ntoa inet_aton) ;
use Config ;

use constant
  { PROG => 'dmon'
  , CDIR => '/etc/dmon'
  , PATH => '/usr/sbin/dmon'
  , REPO => 'https://svn.science.uu.nl/repos/project.dmon/'
  , WORK => 'works'
  , UPGR => 'upgrade'
  , PRBS => 'probes'
  , SECR => 'cgi-secret'
  , CGID => 'cgi-data'
  , PLVL => '315'
  , SPIN_UP => 1
  , SPIN_DO => 0
  , T_EVNTS => 'events'
  , T_MESGS => 'messages'
  , REPITEM => 'reporting'
  , TIME    => 'TIME'
  , IVAL    => 'IVAL'
  , MAIL    => '/usr/sbin/sendmail'
  , LMOD    => 1
  , SRC_DEF => 'config'
  , SRC_SRC => 'source'
  , NO_ALRT => 'no-alert'
  , MODUPGR => 'dmon-upgrade'
  , MSG_TAG => 'MESG'
  } ;

our $VERSION  = '0.05' ; sub VERSION { $VERSION ; } ;

sub get_revision
  { return PLVL unless PLVL =~ /REVISION/ ;
    my $res ;
    if ( -f 'REVISION' )
      { $res = `cat REVISION` ; chomp $res ; }
    else
      { my $tmp = `svn info @{[REPO]} | grep Revision:` ;
        $res = ( $tmp and $tmp =~ /^Revision:\s+(\d+)/ ) ? $1 : 'l' ;
      }
    $res ;
  }

our $REVISION = get_revision ;
our $Version  = "$VERSION-p$REVISION" ;
sub Version { sprintf "%s-%s", PROG, $Version ; }

###################################################################
package OBB ;

use constant PROG => Dmon::PROG ;

our ( @EXPORT, @EXPORT_OK, @ISA ) ;
BEGIN
  { require Exporter ;
    @EXPORT    = qw(logs logq logt logv logd) ;
    @EXPORT_OK = qw() ;
    @ISA       = qw(Exporter)
  }

# use base 'OBB' ; __PACKAGE__ -> mk_getset ( qw(name ...) ) ;

use Carp ;

use constant VLVLS => qw(Silent Quiet Terse Verbose Debug Trace) ;
our %VLVLS = () ;
{ my $cnt = 1 ; $VLVLS { $_ } = $cnt ++ for ( VLVLS ) ; }
{ my $cnt = 1 ; for ( VLVLS ) { $VLVLS { $cnt } = $cnt ; $cnt ++ ; } }
sub _VLVL { $VLVLS { shift @_ } ; }
our $Verbosity = $VLVLS { Terse } ;
# get Verbosity ; or set Verbosity and return previous Verbosity
sub Verbosity
  { my $self = shift ;
    my $res  = $Verbosity ;
    if ( @_ )
      { my $tmp = shift @_ ;
        my $lvl = $VLVLS { $tmp } or die "bad level $tmp" ;
        $Verbosity = $lvl ;
      }
    $res ;
  }
sub logx
  { # sprintf can't have a @list as first argument
    my ( $fmt, @args ) = @_ ;
    my $msg = sprintf $fmt, @args ; chomp $msg ;
    printf "%s %s[%s] %s\n", scalar ( localtime ) , PROG, $$, $msg ;
  }
for my $lvl ( VLVLS )
  { my $num = $VLVLS { $lvl } or die "bad num for lvl [$lvl]" ;
    my $sub = sprintf "sub $lvl { \$Verbosity >= $num ; }" ;
    eval $sub ; die $@ if $@ ;
    my $ini = lc substr $lvl, 0, 1 ;
    $sub = "sub log$ini { logx ( \@_ ) if OBB -> $lvl ; }" ;
    unless ( $lvl eq 'Trace' ) { eval $sub ; die $@ if $@ ; }
  }

sub mk_getset
  { my $self = shift ;
    my $sub  = <<'SUB' ;
sub %s::%s { my $self = shift ; $self -> {%s} = shift if @_ ; $self -> {%s} ; }
SUB
    my @bads = grep ! /^[A-Za-z_]\w*$/, @_ ;
    die "mk_getset: bad name [@bads]\n" if @bads ;
    eval sprintf $sub, $self, $_, $_, $_ for @_ ;
  }
sub mk_get
  { my $self = shift ;
    my $sub  = <<'SUB' ;
sub %s::%s
  { my $self = shift ;
    Carp::confess "mk_get %s : can't set" if @_ ;
    $self -> {%s} ;
  }
SUB
    my @bads = grep ! /^[A-Za-z_]\w*$/, @_ ;
    die "mk_getset: bad name [@bads]\n" if @bads ;
    eval sprintf $sub, $self, $_, $_, $_ for @_ ;
  }
sub New  { my $self = shift ; bless {}, $self ; }
sub Defs { () ; }
sub Init
  { my $self = shift ;
    my %opts = ( $self -> Defs, @_ ) ;
    my @opts = grep { $self -> can ( $_ ) } keys %opts ;
    @$self { @opts } = @opts { @opts } ;
    $self ;
  }
sub Make  { my $self = shift ; $self -> New -> Init ( @_ ) ; }
sub Die
  { my $self = shift ;
    my $fmt  = shift ;
    my $msg  = sprintf "[error] $fmt", @_ ;
    Util::syslog ( $msg ) ;
    die $msg ;
  }
sub Warn
  { my $self = shift ; my $fmt = shift ; warn sprintf "[warng] $fmt\n", @_ ; }
sub Xit
  { my $self = shift ; my $fmt = shift ; confess ( sprintf $fmt, @_ ) ; }
sub A_is { confess ( "! #args == $_[0]" ) unless $_[1] == $_[0] ; }
sub A_ge { confess ( "! #args >= $_[0]" ) unless $_[1] >= $_[0] ; }
sub A_in
  { A_is 3, scalar @_ ;
    my ( $lo, $hi, $sz ) = @_ ;
    confess ( "! #args in [$lo,$hi]" ) unless $lo <= $sz and $sz <= $hi ;
  }
sub A_defd
  { for ( my $i = 0 ; $i < scalar @_ ; $i ++ )
      { confess ( "! defined arg $i" ) unless defined $_[$i] ; }
  }

sub _addr
  { my $x = shift ;
    ( defined $x and ref $x ) ? sprintf ( "%s", $x ) : ref $x ;
  }
sub _blessed
  { my $r = shift ;
    my $res = ( defined $r and ref $r and UNIVERSAL::isa ( $r, 'UNIVERSAL' ) ) ;
    $res ;
  }

sub _unbless ;
sub _unbless
  { my $obj = shift ;
    my $lvl = shift ;
    my $hav = shift ;
    my @pth = @_ ;
    my $ind = '  ' x $lvl ;
    my $res ;
    if ( ! ref $obj )
      { if ( ! defined $obj )
          { $res = undef ; }
        elsif ( $obj eq '' )
          { $res = '' ; }
        else
          { $res = "$obj" ; }
      }
    elsif ( $hav -> { $obj } )
      { $res = sprintf "%s %s", ref $obj, $hav -> { $obj } ; }
    else
      { $hav -> { $obj } = join '/', @pth ;
        my $addr = _addr ( $obj ) ;
        if ( $addr =~ /HASH\(/ )
          { $res = {} ;
            for my $key ( sort keys %$obj )
              { my $val = $obj -> { $key } ;
                $res -> { $key } = _unbless $val, $lvl + 1, $hav, @pth, $key ;
              }
          }
        elsif ( $addr =~ /ARRAY\(/ )
          { my $i = 0 ;
            $res = [ map { _unbless $_, $lvl + 1, $hav, @pth, $i ++ } @$obj ] ;
          }
        elsif ( $addr =~ /GLOB\(/ )
          { $res = $addr ; }
        else
          { die sprintf "can't unbless %s = %s", $addr, ref $obj ; }
      }
    $res ;
  }
sub Unbless { _unbless ( $_[1], 0 ) ; }

# if   $dst == undef : print to \*STDOUT
# elif ref dst == IO::FILE : print to $dst
# else $dst : return Util::as_text
sub Dmp
  { my $obj = shift ;
    my $tag = shift ;
    my $suf = shift || '' ;
    my $fh  = shift || \*STDOUT ;
    my $txt = JSON::PP -> new -> utf8 -> pretty -> canonical
      -> allow_nonref ( 1 ) -> encode ( OBB -> Unbless ( $obj ) ) ;
    $txt .= "\n" unless substr $txt, -1 eq "\n" ;
    print $fh ''
      . ( $tag ? "$tag :\n" : '' )
      . $txt
      . $suf
      ;
  }

sub TT
  { # printf "TT[%s]\n", join '|', @_ ;
    my $fmt = shift || 'TT' ;
    my $txt = sprintf $fmt, map
      { ( ref $_ and $_ -> can ( 'diag' ) )
      ? $_ -> diag
      : Util::diag ( $_ )
      } @_ ;
    my ( $sec, $mic ) = Time::HiRes::gettimeofday ;
    my $res = sprintf "time %.3f %s\n", $sec + $mic / 1000000 - $^T, $txt ;
    print $res if OBB -> Trace ;
    $res ;
  }

###################################################################
package Util ;

our ( @EXPORT, @EXPORT_OK, @ISA ) ;

BEGIN
  { require Exporter ;
    @EXPORT    = qw(syslog) ;
    @EXPORT_OK = qw() ;
    @ISA       = qw(Exporter)
  }

OBB -> import ;

use Exporter ;

use constant PROG => Dmon::PROG ;
use constant MONS => [ qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) ] ;

our $IP_PAT = '^\d{1,3}(\.\d{1,3}){3}$' ;
our $LOGGER = '' ;
our $CONF ;
our $STOP = 'dirty' ;
our $EXEC = 0 ;
our %MONS ; { my $cnt = 0 ; $MONS { $_ } = $cnt ++ for @{+MONS} ; }
sub MON { $MONS { $_[0] } ; }

our $MODE = 0 ; sub MODE { $MODE = shift if @_ ; $MODE ; } ;

sub INITx
  { my $self = shift ;
    my %opts = @_ ;

    $CONF = $opts {conf} ;

    for my $root ( '', '/usr' )
      { for my $bin ( qw(bin sbin) )
          { my $prg = "$root/$bin/logger" ;
            if ( -f $prg ) { $LOGGER = $prg ; last ; }
          }
        last if $LOGGER ;
      }

    my @dirs = qw(logdir rundir vardir upgrdir) ;
    for my $dir ( @dirs )
      { my $xxxdir = $CONF -> $dir ;
        if ( $xxxdir )
          { my $dotdot = Util::dirname ( $xxxdir ) ;
            if ( -d $dotdot )
              { -d $xxxdir or mkdir $xxxdir, 0755
                  or OBB -> Die ( "can't mkdir $xxxdir" ) ;
              }
            else
              { OBB -> Die ( "can't find dir $dotdot" ) ; }
          }
     }
  }

our $_addlog = 0 ;
our $LOGF_hndl ;
sub addlog
  { my $msg = shift ;
    return unless $CONF and ref ( $CONF ) eq 'Conf' ;
    return unless $CONF -> logdir ; # for Pmaker ;
    my $LOGF = $CONF -> log_file ;
    unless ( $LOGF_hndl and defined $LOGF_hndl -> fileno )
      { unless ( $LOGF_hndl = new IO::File ">>$LOGF" )
          { syslog ( "can't append [$LOGF] ($!)" ) unless $_addlog ++ ; }
        else
          { $LOGF_hndl -> autoflush ( 1 ) ; }
      }
    if ( $LOGF_hndl )
      { $LOGF_hndl -> printf
          ( "%s %s[%s] %s\n", scalar ( localtime )
          , PROG, $$, $msg
          ) ;
        $_addlog = 0 ;
      }
  }

sub _syslog
  { my $mesg = shift ;
    my $PROG = PROG ;
    if ( $LOGGER and open SYSL, "|$LOGGER -p user.err -t ${PROG}[$$]" )
      { printf SYSL "$mesg\n" ; close SYSL ; }
  }

sub syslog
  { my $fmt = shift ;
    my $msg = sprintf $fmt, @_ ; chomp $msg ;
    _syslog $msg if $MODE ;
    logt ( $msg . ( $MODE ? " [syslog'ed]" : '' ) ) ;
  }

sub uniq  { my %x = () ; for ( @_ ) { $x { $_ } ++ ; } sort keys %x ; }
sub slice
  { my $h = shift ;
    my $r =
      { map
          { my $v = $h -> $_ ;
            my $x = ( ( ref $v and $v -> can ( 'exp' ) ) ? $v -> exp : $v ) ;
            ( $_ => $x )
          } @_
      } ;
    $r ;
  }

sub diag
  { my $x = shift ;
    $x =~ s/\n/\\n/g if defined $x ;
    unless ( defined $x )
      { '[undef]' ; }
    elsif ( ref $x and $x -> can ( 'diag' ) )
      { sprintf '[%s]', $x -> diag ; }
    elsif ( $x eq '' )
      { '[empty]' ; }
    else
      { my $l = length ( $x ) ; my $c = $l < 1000 ;
        sprintf '[%s]', $c ? $x : substr ( $x, 0, 48 ) . "...($l)"  ;
      }
  }

# $time = timegm($sec,$min,$hour,$mday,$mon,$year);
# Apr 14 00:00:00 2015 GMT
sub secs4date
  { my $date = shift ; chomp $date ;
    if ( $date =~ /^(\w{3})\s+(\d{1,2})\s+(\d{2}:\d{2}:\d{2})\s+(\d{4})/ )
      { my $mon = MON ucfirst lc $1 ;
        my ( $day, $hms, $yea ) = ( $2, $3, $4 ) ;
        my @smh = reverse split /:/, $hms ;
        Time::Local::timegm ( @smh, $day, $mon, $yea ) ;
      }
    else
      { OBB::TT ( 'secs4date: bad date %s', $date ) ; undef ; }
  }

sub get_host_ips
  { my $hnam = shift ;
    my $res  = undef ;
    if ( $hnam =~ /$IP_PAT/ )
      { $res = [ $hnam ] ; }
    elsif ( my $info = Net::hostent::gethost $hnam )
      { $res = [ map { Socket::inet_ntoa $_ ; } @{ $info -> addr_list } ] ; }
    $res ;
  }

# cache localhost_ips ; re-resolve if not defined
our $localhost_ips = get_host_ips 'localhost' ;
sub localhost_ips { $localhost_ips || get_host_ips 'localhost' ; }

sub mk_allowed
  { my $list = shift ;
    my $port = shift ;
    my $res = {} ;
    for my $hnam ( uniq @$list, 'localhost' )
      { my $ips = Util::get_host_ips ( $hnam ) ;
        if ( defined $ips )
          { for my $ip ( uniq @$ips )
              { $res -> { $ip } = { hnam => $hnam, ltim => time } ;
                printf "allow %s %s\n", $port,
                  ( $hnam =~ /$IP_PAT/
                  ? $ip
                  : "$hnam ($ip)"
                  ) if OBB -> Terse ;
              }
          }
        else
          { print "can't resolve $hnam\n" ; }
      }
    $res ;
  }

our $bin_hostname = `hostname` ; chomp $bin_hostname ;
sub bin_hostname { my $self = shift ; $bin_hostname ; }

our $canonical_hostname ;
sub hostname { my $self = shift ; $canonical_hostname ; }
sub hostname_make
  { OBB::A_is ( 3, scalar @_ ) ;
    my $self = shift ;
    my $name = shift ;
    my $cdom = shift ; # configured domain or undef
    my $resolv = Net::DNS::Resolver -> new ;
    my $res = $name ;
    unless ( $res =~ /\./ )
      { my $dom = $cdom || ( $resolv -> searchlist ) [ 0 ] ;
        $res .= ".$dom" if $dom ;
      }
    if ( my $search = $resolv -> search ( $res ) )
      { my @nams = map { $_ -> cname }
          grep { $_ -> type eq 'CNAME' } $search -> answer ;
        $res = $nams [ 0 ] if @nams ;
      }
    OBB::TT ( 'hostname_make(%s,%s) => %s', $name, $cdom, $res ) ;
    printf "hostname_make ( %s , %s ) => %s\n"
      , $name, $cdom || 'no_dom', $res || 'no_res'
        if OBB -> Verbose ;
    $res ;
  }
sub hostname_set
  { OBB::A_is ( 3, scalar @_ ) ;
    my $self = shift ;
    my $name = shift ;
    my $cdom = shift ; # configured domain or undef
    $canonical_hostname = $self -> hostname_make ( $name, $cdom ) ;
  }

hostname_set ( 'Util', $bin_hostname, undef ) ;
# our $canonical_hostname = _canonical_hostname $bin_hostname, undef ;

our $DISTRIB ;
our $RELEASE ;
if ( -f '/usr/bin/lsb_release' )
  { $DISTRIB = lc `/usr/bin/lsb_release -is` ; chomp $DISTRIB ;
    $RELEASE = lc `/usr/bin/lsb_release -rs` ; chomp $RELEASE ;
  }
$DISTRIB ||= 'no_distrib' ;
$RELEASE ||= 'no_release' ;
our $CPU_COUNT = 1 ;
if ( -f '/proc/cpuinfo' )
  { if ( open PROC, '<', '/proc/cpuinfo' )
      { my %ids = () ;
        while ( <PROC> )
          { $ids { $1 } ++ if /^processor\s+:\s*(\S*)$/ ; }
        close PROC ;
        $CPU_COUNT = scalar keys %ids if scalar keys %ids ;
      }
  }

sub as_pvar { my $r = JSON::PP::decode_json ( $_[0] ) ; $r ; }
sub as_text { my $r = JSON::PP::encode_json ( $_[0] ) ; chomp $r ; $r ; }
sub pretty
  { my $v = shift ;
    my $txt = JSON::PP -> new -> utf8 -> pretty -> canonical
      -> allow_nonref ( 1 ) -> encode ( OBB -> Unbless ( $v ) ) ;
    chomp $txt ;
    $txt ;
  }

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 ;
  }

our %s4u = ( 's' => 1 ) ;
$s4u { m } = 60 * $s4u { s } ;
$s4u { h } = 60 * $s4u { m } ;
$s4u { d } = 24 * $s4u { h } ;
$s4u { w } =  7 * $s4u { d } ;

sub s4uv
  { my $v = shift ;
    my $u = shift ;
    $v =  1  unless defined $v and length $v ;
    $u = 's' unless defined $u and length $u ;
    die "500: no s4u {$u}" unless exists $s4u { $u } ;
    $v * $s4u { $u } ;
  }

# return undef on 'bad spec'
# my $msg = '( [+-] NUM [smhdw] ) ...' ;
# $err = "bad spec ($spec) ; should be like '$msg'" ;
sub secs4spec
  { my $spc = shift ;
    my $num = '[-+]?\d+(\.\d)?' ;
    my $one = "($num)?([smhdw]?)" ;
    my $all = "^($one)+\$" ;
    my $res ;

    if ( $spc =~ /$all/ )
      { my $tmp = $spc ;
        $res = 0 ;
        while ( length $tmp )
          { die "500: '$tmp' ~! /^$one/" unless $tmp =~ /^$one/ ;
            my $num  = $1 ;
            my $unit = $3 ;
            $tmp = $' ;
            $res += s4uv $num, $unit ;
          }
      }
    $res ;
  }

sub ddate ($)
  { my $x = shift ;
    my @x = reverse ( ( localtime $x ) [ 0 .. 5 ] ) ;
    $x [ 0 ] += 1900 ; $x [ 1 ] ++ ;
    @x = map { sprintf '%02d', $_ ; } @x ;
    sprintf "%s|%s", join ( '-', @x[(0..2)] ), join ( ':', @x[(3..5)] ) ;
  }

# ( $sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime
sub date ($)
  { my $x = shift ;
    my $thn = [ reverse ( ( localtime $x   ) [ 0 .. 5 ] ) ] ;
    my $now = [ reverse ( ( localtime time ) [ 0 .. 5 ] ) ] ;
    for my $r ( $thn, $now )
      { $r -> [  0 ] = sprintf "%04d", $r -> [ 0 ] + 1900 ;
        $r -> [  1 ] = MONS -> [ $r -> [ 1 ] ] ;
        $r -> [ $_ ] = sprintf "%02d", $r -> [ $_ ] for ( 2 .. 5 ) ;
      }
    while ( @$thn and $thn -> [ 0 ] eq $now -> [ 0 ] )
      { shift @$thn ; shift @$now ; }
    if ( @$thn == 0 )
      { 'now' ; }
    elsif ( @$thn >= 3 )
      { my $hms = join ':', @$thn [ $#$thn - 2 .. $#$thn ] ;
        pop @$thn ; pop @$thn ; pop @$thn ;
        my $ymd = join ' ', @$thn if defined $thn and @$thn ;
        join ' ', grep { defined $_ } ( $ymd, $hms ) ;
      }
    else
      { join ':', @$thn ; }
  }

sub sig_name
  { my $sig = shift ;
    ( split ' ', $Config::Config{'sig_name'} ) [ $sig ] || "sig#$sig" ;
  }

sub rotate
  { my $conf = shift ;
    my $log  = $conf -> log_file ;
    addlog "rotate $log" ;
    my $cnt  = ( split ' ', $conf -> rotate ) [ 0 ] ;
    unlink "$log.$cnt" ; # ignore status
    for ( my $i = $cnt - 1 ; $i > 0 ; $i -- )
      { my $src = sprintf "%s.%s", $log, $i ;
        my $dst = sprintf "%s.%s", $log, $i + 1 ;
        rename $src, $dst or addlog "can't rename $src, $dst"
          if -f $src ;
      }
    my $dst = "$log.1" ;
    my $msg = "can't reopen " ;
    rename $log, $dst or addlog "can't rename $log, $dst" if -f $log ;
    close STDOUT ; open STDOUT, '>>', $log or _syslog ( "$msg STDOUT" ) ;
    close STDERR ; open STDERR, '>>', $log or _syslog ( "$msg STDERR" ) ;
  }

sub get_url
  { my $url  = shift ;
    my $HEAD = shift ;
    OBB -> Xit ( "get_url [$url] HEAD [$HEAD]" ) ;
    addlog "get_url [$url]" ;
    my $UA = LWP::UserAgent -> new ( timeout => 5 ) ;
    my $resp = $HEAD ? $UA -> head ( $url ) : $UA -> get ( $url ) ;
    my $code = $resp -> code ;
    my $ok   = $resp -> is_success ;
    my $lm   = $resp -> header ( 'Last-Modified' ) ;
    my $body = $resp -> content if $ok and not $HEAD ;
    addlog "got_url ok [$ok] code [$code] lm [$lm]" ;
    ( $ok, $body, $code, $lm ) ;
  }

sub md5_text
  { my $txt = shift ;
    my $md5 = Digest::MD5 -> new -> add ( $txt ) -> hexdigest ;
  }

sub md5_file
  { my $file = shift ;
    open FILE, '<', $file or return undef ;
    my $hex = md5_text join '', <FILE> ;
    close FILE ;
    $hex ;
  }

sub text_file
  { my $file = shift ;
    open FILE, '<', $file or return undef ;
    my $res = join '', <FILE> ;
    close FILE ;
    $res ;
  }

# returns $rtt or undef
sub bin_ping
  { my $hnam = shift ;
    my $png = "ping -w 1 -c 1 -q $hnam" ;
    my ( $res, $rtt ) ;
    my $cmd = "$png 2> /dev/null | grep '^rtt'|" ;
    OBB::TT 'bin_ping start %s', $hnam ;
    if ( open PNG, $cmd )
      { my $line = <PNG> ; close PNG ; chomp $line ;
        OBB::TT 'line %s', $line ;
        if ( $line and $line =~ m!= (\d+(\.\d+)?)/! )
          { $res = 1 ; $rtt = $1 ;
          }
      }
    OBB::TT 'bin_ping done res %s %s %s', $res, $rtt, $hnam ;
    defined $res ? $rtt : undef ;
  }

# returns $rtt or undef
sub ping
  { my $hnam = shift ;
    my $max  = shift || 1 ;
    return bin_ping $hnam if $< ;
    OBB::TT 'ping start %s max %s', $hnam, $max ;
    my $png = Net::Ping -> new ( 'icmp', 1 ) ;
    $png -> hires ( 1 ) ;
    my $cnt = 0 ;
    my $min ;
    while ( $cnt < $max )
      { my ( $res, $rtt, $ip ) = $png -> ping ( $hnam ) ;
        OBB::TT 'ping %s done res %s %s %s', $cnt, $res, $rtt, $hnam ;
        if ( $res )
          { $min = $rtt unless defined $min and $rtt > $min ;
            Time::HiRes::usleep 10000 ;
          }
        else
          { sleep 1 ; }
        $cnt ++ ;
      }
    $png -> close () ;
    $min ;
  }

sub uptime { ( split ' ', `cat /proc/uptime` ) [ 0 ] ; }

sub find_bin
  { my $x = shift ;
    my @pref = @_ ;
    if ( $x =~ m!^/! )
      { return $x if -f $x ; }
    else
      { my @path = split /:/, $ENV { PATH } ;
        for my $dir ( @pref, @path )
          { return "$dir/$x" if -f "$dir/$x" ; }
      }
    undef ;
  }

sub systemctl_stat
  { my $bin = find_bin 'systemctl' ;
    my $res = 'no systemctl' ;
    if ( $bin )
      { my @CMD = ( $bin, 'status' ) ;
        if ( open CMD, '-|', @CMD )
          { $res = 'systemctl ; no Failed line' ;
            while ( <CMD> )
              { chomp ;
                if ( /Failed:\s+/ ) { $res = "failed : $'" ; last ; }
              }
            close CMD ;
          }
      }
    $res ;
  }

sub rsync
  { my $hstm = shift ; # host::module
    my $dest = shift ;
    my $sync = find_bin 'rsync' or return "can't find rsync" ;
    my @cmd  = ( $sync, qw(-avz --timeout 10 --no-motd), $hstm, $dest ) ;
    OBB::TT ( '%s', "@cmd" ) ;
    my $res  = system @cmd ;
    my $xit = $? >> 8  ;
    my $sig = $? & 127 ;
    $xit ;
  }

sub run_make
  { my $wher = shift ; -d $wher or return "make can't find dir $wher" ;
    my $what = shift ;
    my $make = find_bin 'make' or return "can't find make" ;
    my $cmd  = "cd $wher ; $make $what" ;
    OBB::TT ( '%s', $cmd ) ;
    my $res  = system $cmd ;
    my $xit = $? >> 8  ;
    my $sig = $? & 127 ;
    $xit ;
  }

sub mk_pipe
  { my @cmd = @_ ;
    my $pipe = IO::Pipe -> new ;
    my $pid = fork () ;
    if ( $pid )
      { # parent
        $pipe -> reader () ;
      }
    elsif ( defined $pid )
      { # child
        alarm 5 ;
        $pipe -> writer () ;
        my $fd = $pipe -> fileno ;
        open STDOUT, ">&=$fd" or die "can't reopen STDOUT" ;
        close STDERR ;
        $pipe -> close or die "child can't close pipe" ;
        exec @cmd ;
      }
    else
      { die "can't fork" ; }
    ( $pid, $pipe ) ;
  }

###################################################################
package Host ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(hnam show ips) ) ;

# may return undef [or die] if hnam not in DNS
sub Init
  { my $self = shift ;
    my %opts =
      ( hnam => Util -> hostname
      , @_
      ) ;
    $self -> OBB::Init ( %opts ) ;
    my $hnam = $opts { hnam } ;
    my $ips  = $opts { ips } || Util::get_host_ips ( $hnam ) ;
    if ( defined $ips )
      { $self -> ips ( $ips ) ; }
    else
      { # OBB -> Die ( "no ips for [$hnam]" ) ;
        return undef ;
      }
    $self ;
  }

sub ping { my $self = shift ; Util::ping $self -> hnam, @_ ; }
sub diag { my $self = shift ; Util::diag $self -> hnam ; }

###################################################################
# state from reporting
# t_state set by server
# wrkr from work-file
package Host::Client ;
use base 'Host' ;
__PACKAGE__ -> mk_getset ( qw(state t_state wrkr) ) ;

sub Init { my $self = shift ; $self -> Host::Init ( @_ ) ; $self ; }

sub has_item
  { my $self = shift ; my $inam = shift ;
    exists $self -> {state} and exists $self -> {state} { $inam } ;
  }

###################################################################
package Host::Pmaker ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(xargs xfits) ) ;

###################################################################
# stub for Server, Client, Pmaker ; App's must init 'hnam'
package App ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset
  ( qw(conf work threads service Items rejects time0) ) ;

sub Init
  { my $self = shift ;
    my %opts = ( threads => undef, SERVICE => 1, @_ ) ;
    my $conf = $self -> conf ( $opts { conf } ) ;
    my $threads = $opts { threads } ;
    OBB::TT 'App Init %s', $self ;
    die "App : no hostname" unless $self -> hnam ;
    my $work = $self -> work ( $self -> mk_work ) ;
    my $Items = $self -> Items ( Items -> Make ( conf => $conf ) ) ;
    $Items -> add_items ( $work -> items ) ;
    $self -> threads ( $threads ) ;
    if ( $opts{SERVICE} and $self -> threads )
      { my $PORT = $self -> PORT ;
        $self -> service
          ( $threads -> Add
              ( Dmon::Thread::Service -> Make ( port => $PORT ), $self )
          ) ;
        $self -> service -> mk_allowed ( $self -> allowed, $PORT ) ;
      }
    $self -> rejects ( Dmon::Rejects -> Make ) ;
    $self -> time0 ( time ) ;
    OBB::TT 'App Init done %s', $self ;
    $self ;
  }

sub add_reject { $_[0] -> rejects -> add ( $_[1] ) ; }
sub del_reject { $_[0] -> rejects -> del ( $_[1] ) ; }

sub _sender_to_me
  { my $self = shift ;
    my $hnam = shift ; $hnam = $hnam -> hnam if ref $hnam ;
    my $port = shift ;
    my $msgs = shift ;
    my $res = Dmon::Thread::Send -> Make
      ( hnam => $hnam
      , port => $port
      , mbox => $msgs
      ) ;
    $self -> threads -> Add ( $res, $self ) if $res ;
    $res ;
  }

sub new_work
  { my $self = shift ;
    my $lm   = shift ;
    unless ( $lm )
      { OBB::TT "new_work : no lm ; fetch work" ;
        my $work = $self -> mk_work ( Dmon::LMOD ) ;
        $lm = $work -> stamp if $work ;
        OBB::TT "new_work : no lm ; no work" unless $work ;
      }
    OBB::TT ( "new_work : self %s lm %s", $self -> work -> stamp, $lm ) ;
    $lm and $self -> work -> stamp < $lm ;
  }

sub _work_file
  { OBB::A_is ( 3, scalar @_ ) ;
    my $wdir = shift || 'no_dir' ;
    my $prog = shift || 'no_prog' ;
    my $hnam = shift || 'no_host' ;
    sprintf "%s/%s/%s.txt", $wdir, $prog, $hnam ;
  }
sub work_file
  { my $self = shift ;
    _work_file $self -> conf -> workdir, $self -> PROG, $self -> hnam ;
  }

sub _work_cmd
  { OBB::A_is ( 3, scalar @_ ) ;
    my $prog = shift || 'no_prog' ;
    my $hnam = shift || 'no_host' ;
    my $lmod = shift ;
    sprintf "%s %s %s", ( $lmod ? 'WORK_LM' : 'WORK' ), $prog, $hnam ;
  }
sub work_cmd
  { my ( $self, $lmod ) = @_ ;
    _work_cmd $self -> PROG, $self -> hnam, $lmod ;
  }

sub mk_work
  { my $self = shift ; $self -> Xit ( 'called stub App::mk_work' ) ; }
sub command
  { my $self = shift ; $self -> Xit ( 'called stub App::command' ) ; }

sub DEF_IVAL { my $self = shift ; $self -> conf -> ival_make_state ; }

###################################################################
package Server ;
use base qw(Host App) ;
__PACKAGE__ ->
  mk_getset ( qw(clients users alerts levels by_ip Tzero CLIENT) ) ;
sub Defs
  { ( Host -> Defs
    , App  -> Defs
    , clients => {}
    , users   => {}
    , alerts  => []
    , by_ip   => {}
    , Tzero   => time
    ) ;
  }

use constant { PROG => 'dmon-server' } ;

sub Init
  { my $self = shift ;
    my %opts = @_ ;
    my $conf = $opts{conf} ;
    for my $dir ( map { $conf -> $_ } qw(workdir upgrdir) )
      { $self -> Die ( "Server: no dir $dir" ) unless -d $dir ; }
    for my $fil ( map { $conf -> $_ } qw(upgr_file) )
      { $self -> Die ( "Server: no file $fil" ) unless -f $fil ; }
    $self -> Host::Init ( @_ ) ;
    $self -> App::Init  ( @_ ) ;
    $self -> levels ( Fitl -> mk_levels ( $self -> work -> levels ) ) ;
    $self -> set_clients ;
    $self -> set_users ;
    $self -> set_alerts ;
    $self ;
  }

sub PORT { my $self = shift ; $self -> conf -> port_server ; }

sub allowed
  { my $self = shift ; $self -> work ? $self -> work -> wrkrs : [] ; }

sub mk_work
  { my ( $self, $lmod ) = @_ ;
    Work::Server -> make_from_file ( $self -> work_file, $lmod ) ;
  }

sub set_clients
  { my $self  = shift ;
    my $hosts = $self -> work -> hosts ;
    for my $host ( @$hosts )
      { my $client = Host::Client -> Make ( %$host ) ;
        $self -> clients -> { $client -> hnam } = $client ;
        if ( defined $client and defined $client -> ips )
          { for my $ip ( @{ $client -> ips } )
              { $self -> by_ip -> { $ip } = $client ; }
          }
      }
  }

sub set_users
  { my $self  = shift ;
    my $works = $self -> work -> users ;
    for my $work ( @$works )
      { my $user = User -> Make ( %$work ) ;
        $self -> users -> { $user -> name } = $user ;
      }
  }

sub set_alerts
  { my $self  = shift ;
    my $works = $self -> work -> alerts ;
    for my $work ( @$works )
      { my $users = $work -> {users} ;
        my $alert = Alert -> Make
          ( users => [ map { $self -> users -> { $_ } } @$users ]
          , levl1 => { map { ( $_ => 1 ) } @{ $work -> {levl1} } }
          , levl2 => { map { ( $_ => 1 ) } @{ $work -> {levl2} } }
          , hosts => { map { ( $_ => 1 ) } @{ $work -> {hosts} } }
          , items => { map { ( $_ => 1 ) } @{ $work -> {items} } }
          ) ;
        push @{ $self -> alerts }, $alert ;
      }
  }

# my $cli = $self -> clients -> { $hnm } ;
# $cli -> state ( $rep ) ;
# $cli -> t_state ( time ) ;

sub check_reporting
  { my $self = shift ;
    my $ival = $self -> conf -> ival_send_report ;
    my $init = time < $self -> Tzero + $ival ;
    OBB::TT '  check_reporting init %s ...', $init || 0 ;
    my $clnts = $self -> clients ;
#   { for my $hnam ( keys %$clnts )
#       { my $cli = $clnts -> { $hnam } ;
#         OBB::TT ( "*** hnam %s wrkr %s", $hnam, $cli -> {wrkr} ) ;
#       }
#   }
    return scalar grep
      { defined $_ and defined $_ -> t_state and $_ -> t_state }
        values %$clnts if $init ;
    my $table = Dmon::T_EVNTS ;
    my $res = 0 ;
    my $evlst = $self -> CLIENT -> hist -> select_hash
      ( $table
      , cols     => 'e2.*'
      , from     => "$table e1 left join $table e2 using ( TIME, hnam )"
      , where    => sprintf ( "e1.item = '%s'", Dmon::REPITEM )
      , group_by => 'hnam'
      , having   => 'TIME = MAX ( TIME )'
      , order_by => 'TIME'
      ) ;
    my %evnts = map
      { my $event = Event -> Make ( %$_ ) ;
        ( $event -> hnam => $event ) ;
      } @$evlst ;
    for my $hnam ( sort keys %$clnts )
      { my $cli = $clnts -> { $hnam } ;
        my $tim = $cli -> t_state ;
        next unless defined $tim ;
        # one miss is allowed
        my $age  = int ( abs ( time - $tim ) / $ival - 1.5 ) ;
        my $lmax = @{ $self -> levels } - 1 ;
        my $lnew = ( $age < 0 ? 0 : ( $age > $lmax ? $lmax : $age ) ) ;
        my $last = $evnts { $hnam } ;
        my $lold = $last ? $last -> lnew : 0 ;
        my $wrkr = $cli -> {wrkr} ;
        next if $wrkr and not ( $lnew == 0 or $lnew == $lmax ) ;
        if ( $lnew != $lold )
          { OBB::TT
              ( 'hnam %s age %s lold %s lnew %s'
              , $hnam, $age, $lold, $lnew
              ) ;
            my $evnt = Event -> Make
              ( hnam => $hnam
              , item => Dmon::REPITEM
              , lold => $lold
              , lnew => $lnew
              , mesg => "age [$age]"
              ) ;
            $evnt -> save ( $self -> CLIENT -> hist ) ;
            $evnt -> send_mail ( $self ) unless $wrkr ;
          }
        $res ++ unless $lnew ;
      }
    $res ;
  }

sub send_client
  { OBB::A_is ( 2, scalar @_ ) ;
    my $self = shift ;
    my $hnam = shift ;
    my $PORT = $self -> conf -> port_client ;
    my $clnt = $self -> clients -> { $hnam } ;
    my $res ;
    OBB::TT 'to client PORT %s', $PORT ;
    if ( $clnt )
      { $res = $self -> _sender_to_me ( $clnt, $PORT ) ; }
    else
      { $res = undef ; }
    $res ;
  }

sub cnt_clients { my $self = shift ; scalar keys %{ $self -> clients } ; }
sub show_client
  { OBB::A_is ( 2, scalar @_ ) ;
    my ( $self, $hnam ) = @_ ;
    my $host = $self -> clients -> { $hnam } ;
    ( $host
    ? ( sprintf '%s [%s]', $host -> show, $host -> hnam )
    : ( sprintf '%s [%s]', $hnam, 'not yet found' )
    ) ;
  }
sub works4
  { OBB::A_is ( 2, scalar @_ ) ;
    my ( $self, $hnam ) = @_ ;
    my $clnts = $self -> clients ;
    [ sort grep { $clnts -> { $_ } {wrkr} eq $hnam } keys %$clnts ] ;
  }

# Server allow_command
sub allow_command
  { my $self = shift ;
    my $cmd  = shift ;
    my $thrd = shift ;
    my $peer = $thrd -> inp -> peerhost ;
    my $res  = 1 ;
    # command UPGRADE is only allowed from localhost
    if ( $cmd eq 'UPGRADE' )
      { my $ips = Util::localhost_ips () ;
        $res = $ips ? grep { $peer eq $_ } @$ips : 0 ;
      }
    elsif ( $cmd eq 'NO_ALRT' )
      { my $pmkr = $self -> work -> pmaker ;
        my $host = $self -> clients -> { $pmkr } ;
        my $ips  = $host ? $host -> ips : [] ;
        $res = $ips ? grep { $peer eq $_ } @$ips : 0 ;
      }
    $res ;
  }

# Server command ; must return undef for unknown command
sub command
  { my $self = shift ;
    my $cmd  = shift ;
    my $arg  = shift ;
    my $thrd = shift ;
    my $peer = $thrd -> inp -> peerhost ;
    my $res  = undef ;
    if ( ! $self -> allow_command ( $cmd, $thrd ) )
      { $res = "command not allowed [$cmd] from $peer" ; }
    elsif ( $cmd eq 'WORK' )
      { $res = $self -> do_work ( $arg, $thrd ) ; }
    elsif ( $cmd eq 'WORK_LM' )
      { $res = $self -> do_work ( $arg, $thrd, 1 ) ; }
    elsif ( $cmd eq 'PROG' )
      { $res = $self -> do_prog ( $arg, $thrd ) ; }
    elsif ( $cmd eq 'EVENTS' )
      { my $val = JSON::PP::decode_json ( $arg || '[]' ) ;
        $res = $self -> do_events ( $val, $peer ) ;
      }
    elsif ( $cmd eq 'CLIENT' )
      { $res = $self -> do_client ( $arg, $thrd ) ; }
    elsif ( $cmd eq 'CLIENTS' )
      { $res = $self -> do_clients ( $arg ) ; }
    elsif ( $cmd eq 'ALLPING' )
      { $res = $self -> do_allping ( $arg, $thrd ) ; }
    elsif ( $cmd eq 'ALLSEND' )
      { $res = $self -> do_allsend ( $arg, $thrd ) ; }
    elsif ( $cmd eq 'ALLMETA' )
      { $res = $self -> do_allmeta ( $arg, $thrd ) ; }
    elsif ( $cmd eq 'UPGRADE' )
      { $res = $self -> do_upgrade ( $arg, $thrd ) ; }
    elsif ( $cmd eq 'NO_ALRT' )
      { $res = $self -> do_no_alrt ( $arg, $thrd ) ; }
    $res ;
  }

sub do_client
  { my $self = shift ;
    my $arg  = shift ;
    my $thrd = shift ;
    my ( $hnam, $cmd ) = split ' ', $arg, 2 ;
    my $sndr = $self -> send_client ( $hnam ) ;
    return "can't connect to client ($hnam)" unless $sndr ;
    $thrd -> wait4 ( $sndr ) ;
    $sndr -> send ( $cmd ) ;
    # result is ignored
  }

# Server _do_all
sub _do_all
  { OBB::A_in 4, 5, scalar @_ ;
    my $self = shift ;
    my $arg  = shift ;
    my $thrd = shift ;
    my $cmd  = shift ;
    my $skip = shift || 0 ; # skip server
    my $hsts = $self -> work -> wrkrs ;
    my $res  = [] ;
    my $CMD  = $cmd ; $CMD .= " $arg" if defined $arg ;
    $thrd -> proxy ( 0 ) ;
    for my $hnam ( @$hsts )
      { next if $skip and $hnam eq Util -> hostname ;
        OBB::TT "send $cmd to %s", $hnam ;
        if ( my $sndr = $self -> send_client ( $hnam ) )
          { $thrd -> wait4 ( $sndr ) ;
            $sndr -> send ( $CMD ) ;
          }
        else
          { push @$res, "can't connect to $hnam" ; }
      }
    push @$res, "ALL$cmd : no hosts reachable" unless $thrd -> waitc ;
    OBB::TT "ALL$cmd is waiting for %s hosts", $thrd -> waitc ;
    join '', map "$_\n", @$res ;
  }

# default : skip server ;
sub do_allping { _do_all @_, 'PING', 0 ; }
sub do_allsend { _do_all @_, 'SEND', 1 ; }
sub do_allmeta { _do_all @_, 'META', 0 ; }

# Server do_report
sub do_report
  { my $self = shift ;
    my $rprt = shift ;
    my $from = shift ;
    my $resp = 'ok' ;
    my $clnt = $self -> by_ip -> { $from } ;
    my $work = undef ;
    if ( $clnt )
      { my $hnam = $clnt -> hnam ;
        my $clnts = $self -> clients ;
        my @bads = grep { ! $self -> clients -> { $_ } } keys %$rprt ;
        if ( @bads )
          { $resp = "no client for [@bads] from $hnam [$from]" ; }
        elsif ( scalar keys %$rprt == 0 )
          { $resp = "no keys in report from $hnam [$from]" ; }
        else
          { my @fors = () ;
            for my $hnm ( sort keys %$rprt )
              { my $rep = $rprt -> { $hnm } ;
                my $cli = $self -> clients -> { $hnm } ;
                $cli -> state ( $rep ) ;
                $cli -> t_state ( time ) ;
                push @fors, $hnm ;
              }
            $resp = "ok report from $hnam" ;
            $resp .= " [$from]" . ( @fors ? " for @fors" : '' )
              unless @fors == 1 and $fors[0] eq $hnam ;
            my $path = App::_work_file
              ( $self -> conf -> workdir, Client -> PROG, $hnam ) ;
            OBB::TT "work_file %s", $path ;
            $work = ( stat $path ) [ 9 ] || 0 ;
          }
      }
    else
      { $resp = "no client for $from" ; }

    Util::as_text { resp => $resp, work => $work } ;
  }

# Server do_events
sub do_events
  { my $self  = shift ;
    my $evnts = shift ;
    my $from  = shift ;
    my $resp  = 'ok' ;
    my $clnt  = $self -> by_ip -> { $from } ;
    unless ( ref ( $evnts ) =~ /ARRAY/ )
      { $resp = "not an ARRAY ($evnts)" ; }
    elsif ( $clnt )
      { my $hnam  = $clnt -> hnam ;
        my $clnts = $self -> clients ;
        my @nohst = () ;
        my @noitm = () ;
        my @bdlvl = () ;
        my $levls = $self -> CLIENT -> hash_level_names ;
        for my $e ( @$evnts )
          { my $h = $e -> {hnam} || 'no_hnam' ;
            my $i = $e -> {item} || 'no_item' ;
            my $l = $e -> {levl} || $self -> CLIENT -> level0 ;
            unless ( $clnts -> { $h } )
              { push @nohst, $h ; }
            elsif ( ! $clnts -> { $h } -> has_item ( $i ) )
              { push @noitm, "$h:$i" ; }
            elsif ( ( $e -> {type} || '' ) eq Dmon::MSG_TAG )
              { if ( exists $levls -> { $l } )
                  { $e -> {levl} = $levls -> { $l } ; }
                else
                  { push @bdlvl, "$h:$i lvl '$l'" ; }
              }
          }
        if ( @nohst )
          { $resp = "no client for [@nohst] in events from $hnam [$from]" ; }
        elsif ( @noitm )
          { $resp = "no item for [@noitm] in events from $hnam [$from]" ; }
        elsif ( @bdlvl )
          { $resp = "bad level in [@bdlvl] in events from $hnam [$from]" ; }
        elsif ( @$evnts == 0 )
          { $resp = "no events from $hnam [$from]" ; }
        elsif ( ! ( $self -> CLIENT and $self -> CLIENT -> hist ) )
          { $resp = "can't find a history" ; }
        else
          { my @fors = () ;
            for my $hash ( @$evnts )
              { if ( ( $hash -> {type} || '' ) eq Dmon::MSG_TAG )
                  { my $Mesg = Message -> Make ( %$hash ) ;
                    $Mesg -> save ( $self -> CLIENT -> hist ) ;
                    push @fors, $Mesg -> hnam ;
                  }
                else
                  { my $Evnt = Event -> Make ( %$hash ) ;
                    $Evnt -> save ( $self -> CLIENT -> hist ) ;
                    push @fors, $Evnt -> hnam ;
                    $Evnt -> send_mail ( $self ) ;
                  }
              }
            $resp = "ok events from $hnam [$from]"
              . ( @fors ? " for @fors" : '' ) ;
          }
      }
    else
      { $resp = "no client for $from" ; }
    Util::as_text { resp => $resp } ;
  }

sub _events
  { my $self = shift ;
    my $tnam = shift ;
    my $arg  = shift || 0 ;
    my $hnam = shift ;
    my $inam = shift ;
    my $res  = [] ;
    my $hist = $self -> CLIENT -> hist if $self -> CLIENT ;
    my %sel  = ( order_by => 'TIME DESC' ) ;
    my @qwe  = () ;
    push @qwe, "hnam = '$hnam'" if $hnam ;
    push @qwe, "item = '$inam'" if $inam ;
    my $secs ;
    if ( $arg =~ /^\d+$/ )
      { $sel { limit } = $arg if $arg > 0 ; }
    elsif ( defined ( $secs = Util::secs4spec ( $arg ) ) )
      { push @qwe, sprintf "TIME >= %s", time - $secs ; }
    $sel { where } = join ' AND ', @qwe if @qwe ;
    if ( $hist )
      { $res = $hist -> select_hash ( $tnam, %sel ) ; }
    $res ;
  }

sub events { my $self = shift ; $self -> _events ( Dmon::T_EVNTS, @_ ) ; }
sub mesgs  { my $self = shift ; $self -> _events ( Dmon::T_MESGS, @_ ) ; }

sub _mintime
  { my $self = shift ;
    my $tnam = shift ;
    my $hist = $self -> CLIENT -> hist if $self -> CLIENT ;
    $hist ? $hist -> min ( $tnam, Dmon::TIME ) : undef ;
  }

sub event0 { my $self = shift ; $self -> _mintime ( Dmon::T_EVNTS ) ; }
sub mesg0  { my $self = shift ; $self -> _mintime ( Dmon::T_MESGS ) ; }

sub do_clients
  { my $self = shift ;
    my $arg  = shift ;
    my @args = split ' ', $arg ;
    my $hnam ;
    my $inam ;
    while ( @args and $args[0] =~ /^-/ )
      { my $flag = shift @args ;
        return Util::as_text { resp => "bad arg $arg" } unless @args ;
        if ( $flag eq '-h' )
          { $hnam = shift @args ; }
        elsif ( $flag eq '-i' )
          { $inam = shift @args ; }
        else
          { return Util::as_text { resp => "bad flag [$flag] in $arg" } ; }
      }
    my $espc = shift @args ; # EVNT spec
    my $mspc = shift @args ; # MESG spec
    my $cdmp = $self -> clients ;
    my $resp = 'ok clients' ;
    if ( $hnam )
      { my $tmp = {} ;
        if ( not exists $cdmp -> { $hnam } )
          { return Util::as_text { resp => "no host $hnam" } ; }
        else
          { $tmp = { $hnam => $cdmp -> { $hnam } } ; }
        $cdmp = $tmp ;
      }
    if ( $inam )
      { my $tmp = {} ;
        for my $hnam ( keys %$cdmp )
          { my $host = $cdmp -> { $hnam } ;
            $tmp -> { $hnam } = $host if $host -> has_item ( $inam ) ;
          }
         $cdmp = $tmp ;
      }
    if ( $hnam or $inam )
      { $resp = sprintf 'ok clients host %s ; item %s'
          , $hnam || '*', $inam || '*' ;
      }
    Util::as_text
      { resp   => $resp
      , cdmp   => OBB -> Unbless ( $cdmp )
      , events => $self -> events ( $espc, $hnam, $inam )
      , event0 => $self -> event0
      , mesgs  => $self -> mesgs  ( $mspc, $hnam, $inam )
      , mesg0  => $self -> mesg0
      , noalrt => $self -> conf -> no_alert
      , rejects => OBB -> Unbless ( $self -> rejects -> hash )
      , time0  => $self -> time0
      } ;
  }

sub _path { join ( '/', @_ ) . '.txt' ; }

sub do_work
  { my $self = shift ;
    my $arg  = shift ;
    my $thrd = shift ;
    my $lmod = shift || 0 ;
    my $wdir = $self -> conf -> workdir ;
    my $resp ;
    my ( $prog, $hnam ) = split ' ', $arg, 2 ;
    my $path = App::_work_file ( $wdir, $prog, $hnam ) ;
    unless ( $prog )
      { $resp = 'no prog' ; }
    elsif ( ! $hnam )
      { $resp = 'no hnam' ; }
    elsif ( ! -f $path )
      { $resp = "no work [$path]" ; }
    elsif ( ! open PATH, '<', $path )
      { $resp = "can't open work [$path]" ; }
    return Util::as_text { resp => $resp } if $resp ;
    my $json ;
    unless ( $lmod )
      { $json = Util::as_pvar join '', <PATH> ; close PATH ; }
    my $lm = ( stat $path ) [ 9 ] || 0 ;
    Util::as_text { resp => 'ok work', data => $json, lm => $lm } ;
  }

# Server do_upgrade
sub do_upgrade
  { my $self = shift ;
    my $arg  = shift ;
    my $thrd = shift ;
    my $conf = $self -> conf ;
    my $hsts = $self -> work -> wrkrs ;
    my $res  = [] ;
    my @args = split ' ', $arg ;
    my $optf = ( ( @args and $args[0] eq '-f' ) ? shift @args : '' ) ;
    my %only = map { ( $_ => 1 ) } @args ;
    my $dmon = $conf -> upgr_file ;
    my $vers = `perl $dmon --version` ; chomp $vers ;
    return "can't get $dmon --version" unless defined $vers ;
    my $json = Util::as_text { version => ( $optf ? undef : $vers ) } ;
    $thrd -> proxy ( 0 ) ;
    for my $hnam ( @$hsts )
      { # skip the server
        next if $hnam eq Util -> hostname ;
        next if @args and ! $only { $hnam } ;
        OBB::TT "send upgrade to %s", $hnam ;
        if ( my $sndr = $self -> send_client ( $hnam ) )
          { $thrd -> wait4 ( $sndr ) ;
            $sndr -> send ( "UPGRADE $json" ) ;
          }
        else
          { push @$res, "can't connect to $hnam" ; }
      }
    push @$res, 'no hosts reachable' unless $thrd -> waitc ;
    OBB::TT 'waiting for %s hosts', $thrd -> waitc ;
    join '', map "$_\n", @$res ;
  }

sub do_prog
  { my $self = shift ;
    my $arg  = shift ;
    my $thrd = shift ;
    my $resp ;
    my $path = $self -> conf -> upgr_file ;
    if ( ! open PATH, '<', $path )
      { $resp = "can't open prog [$path]" ; }
    return Util::as_text { resp => $resp } if $resp ;
    my $text = join '', <PATH> ;
    close PATH ;
    my $lm = ( stat $path ) [ 9 ] || 0 ;
    Util::as_text { resp => "ok prog $path", data => $text, lm => $lm } ;
  }

sub do_no_alrt
  { my $self = shift ;
    my $arg  = shift ;
    my $thrd = shift ;
    my $res  = $self -> conf -> no_alert ;
    my $resp = "ok no_alert [$arg]" ;
    if ( $arg =~ /^\w+$/ )
      { if ( $arg eq '0' )
          { $res .= ' -> ' . $self -> conf -> no_alert ( $arg ) ; }
        elsif ( $self -> users -> { $arg } )
          { $res .= ' -> ' . $self -> conf -> no_alert ( $arg ) ; }
        else
          { $resp = "no valid arg [$arg]" ; }
      }
    Util::as_text { resp => $resp, res => $res } ;
  }

# Server
sub STATE
  { my $self = shift ;
    sprintf "-- Server state : keeping state for %d clients"
      , $self -> cnt_clients ;
  }

###################################################################
package Client ;
use base qw(Host App) ;
__PACKAGE__ -> mk_getset
  ( qw(server items state levels rexec hist next_send SERVER vals) ) ;

use constant
  { PROG => 'dmon-client'
  , STOPPED => 'STOPPED'
  } ;

sub Init
  { my $self = shift ;
    OBB::TT 'Client Init %s', $self ;
    $self -> Host::Init ( @_ ) ;
    $self -> App::Init  ( @_ ) ;
    $self -> set_server ;
    $self -> levels ( Fitl -> mk_levels ( $self -> work -> levels ) ) ;
    my $state = State::Client -> Make
      ( work   => $self -> work
      , IVAL   => $self -> DEF_IVAL
      , levels => $self -> levels
      , Items  => $self -> Items
      ) ;
    $self -> state ( $state ) ;
    $self -> next_send ( time ) ;

    OBB::TT 'Client ref self %s', ref $self ;
    $self -> hist ( $self -> make_db ) unless ref $self eq 'Pmaker' ;
    $self -> vals ( Vals -> Make ) ;
    OBB::TT 'Client Init done %s', $self ;
    $self ;
  }

sub mk_update
  { my $self = shift ;
    my $hnam = shift ;
    $self -> state -> mk_update ( $hnam, $self ) ;
  }

sub make_db
  { my $self = shift ;
    my $file = $self -> conf -> dbs_file ;
    my $hist = TS -> Make ( file => $file ) ;
    my $dbh  = $hist -> connect ;
    return undef unless $hist -> dbh ;
    OBB::TT 'db connected %s file %s', !! $hist -> dbh, $file ;

    my $state = $self -> state ;
    for my $hnam ( $self -> state -> hnams )
      { my $tnam = $hist -> tnam ( $hnam ) ;
        $hist -> add_tab ( $tnam ) unless $hist -> has_tab ( $tnam ) ;
        my @items = @{ $state -> host_items ( $hnam ) } ;
        my @names = ( map { $_ -> name } @items ) ;
        for my $nam ( @names )
          { $hist -> add_col ( $tnam, $nam, 'real' )
              unless $hist -> has_col ( $tnam, $nam ) ;
          }
        my $IVAL = Dmon::IVAL ;
        unless ( $hist -> has_col ( $tnam, $IVAL ) )
          { $hist -> add_col ( $tnam, $IVAL, 'real', 'NOT NULL DEFAULT 1' ) ;
            $hist -> dbh -> do ( "UPDATE $tnam SET IVAL = 1" ) ;
          }
        my %want = ( $IVAL => 1, map { ( $_ => 1 ) } @names ) ;
        my @drop = () ;
        for my $col ( sort $hist -> user_cols ( $tnam ) )
          { push @drop, $col unless $want { $col } ;
            OBB::TT "col [$col] want %s", $want { $col } ;
          }
        if ( @drop )
          { OBB::TT "drop [@drop] from $tnam" ;
            $hist -> drop_cols ( $tnam, @drop ) ;
          }
      }
    my $tnam = Dmon::T_EVNTS ;
    my $sql  = Event -> SQL_CREATE_TAB ( $tnam ) ;
    $hist -> dbh -> do ( $sql ) unless $hist -> has_tab ( $tnam ) ;
    for my $col ( Event -> SQL_ADD_COLS )
      { $hist -> add_col ( $tnam, $col, 'real' )
          unless $hist -> has_col ( $tnam, $col ) ;
      }
    $tnam = Dmon::T_MESGS ;
    $hist -> dbh -> do ( Message -> SQL_CREATE_TAB ( $tnam ) )
      unless $hist -> has_tab ( $tnam ) ;
    OBB::TT 'make_db done' ;
    $hist ;
  }

sub save_hist
  { my $self = shift ;
    my $hnam = shift ;
    my $hash = shift ;
    my $hist = $self -> hist ;
    if ( $hist )
      { my $tnam = $hist -> tnam ( $hnam ) ;
        $hist -> save_hash ( $tnam, $hash ) ;
      }
  }

sub last_hist
  { my $self = shift ;
    my $hnam = shift ;
    my $hash = shift ;
    my $hist = $self -> hist ;
    my $res  = {} ;
    if ( $hist )
      { my $tnam = $hist -> tnam ( $hnam ) ;
        $res = $hist -> select1_hash
          ( $tnam
          , where => "TIME = ( select MAX(TIME) FROM $tnam )"
          ) ;
      }
    $res ;
  }

sub show_levels
  { my $self = shift ;
    join ',', map { $_ -> show } @{ $self -> levels } ;
  }

sub hash_level_names
  { my $self = shift ;
    my $res  = {} ;
    for my $levl ( @{ $self -> levels } )
      { $res -> { $levl -> name } = $levl -> levl ; 
        $res -> { $levl -> show } = $levl -> levl ; 
      }
    $res ;
  }
sub level0 { my $self = shift ; $self -> levels -> [ 0 ] -> name ; }

sub PORT    { my $self = shift ; $self -> conf -> port_client ; }
sub allowed { my $self = shift ; [ $self -> conf -> server ] ; }

sub mk_work
  { my ( $self, $lmod ) = @_ ;
    if ( $self -> hnam eq $self -> conf -> server )
      { Work::Client -> make_from_file ( $self -> work_file, $lmod ) ; }
    else
      { Work::Client -> make_from_serv ( $self, $lmod ) ; }
  }

sub send_server_sync
  { my $self = shift ;
    my $mesg = shift ;
    my $pack = shift ;
    my $res  = undef ;
    my $SOCK = IO::Socket::INET -> new
      ( PeerAddr => $self -> conf -> server
      , PeerPort => $self -> conf -> port_server
      , Proto => 'tcp'
      ) ;
    if ( $SOCK )
      { printf $SOCK "$mesg\n" ;
        $SOCK -> shutdown ( 1 ) ; # done writing
        my @lines = <$SOCK> ;
        $SOCK -> shutdown ( 2 ) ; # done using
        $res = $pack -> Make ( lines => [ @lines ] ) if @lines ;
      }
    $res ;
  }

# returns undef on "can't connect"
sub get_work_mesg
  { my ( $self, $lmod ) = @_ ;
    my $cmd  = $self -> work_cmd ( $lmod ) ;
    $self -> send_server_sync ( $cmd, 'Dmon::Mesg::Work' ) ;
  }

sub set_server
  { my $self = shift ;
    my $serv = Host -> Make ( hnam => $self -> conf -> server ) ;
    OBB::TT 'server %s', $serv || 'no server' ;
    $self -> server ( $serv ) ;
  }

sub send_server
  { my $self = shift ;
    my $mesg = shift ;
    my $msgs = shift ;
    my $PORT = $self -> conf -> port_server ;
    my $res ;
    $self -> Xit ( 'no server?' ) unless $self -> server ;
    OBB::TT 'to server PORT %s', $PORT ;
    if ( $self -> server )
      { $res = $self -> _sender_to_me ( $self -> server, $PORT, $msgs ) ;
        $res -> send ( $mesg ) if $res and defined $mesg ;
      }
    $res ;
  }

sub send_server_reboot
  { my $self = shift ;
    my $hnam = shift ;
    my $mbox = shift ;
    my $last = $self -> last_hist ( $hnam ) ;
    my $curr = Util::uptime ;
    my $prev = $last -> { uptime } if $last ;
    my $msg = Util::systemctl_stat ;
    if ( defined $curr and defined $prev and $curr < $prev )
      { OBB::TT 'send reboot-event to server %s ; %s', $hnam, $msg ;
        $self -> send_server
          ( sprintf
              ( 'EVENTS %s'
              , Util::as_text
                  [ { hnam => $hnam
                    , item => 'uptime'
                    , levl => 0
                    , mesg => "reboot ; $msg"
                    , type => Dmon::MSG_TAG
                  } ]
              )
          , $mbox
          ) ;
      }
    else
      { OBB::TT 'no reboot-event to server %s %s', $hnam, $msg ; }
  }

# Client allow_command
sub allow_command
  { my $self = shift ;
    my $cmd  = shift ;
    my $thrd = shift ;
    my $peer = $thrd -> inp -> peerhost ;
    my $res  = 1 ;
    # commands not allowed from localhost
    my @COMMANDS = qw(UPGRADE) ;
    if ( grep { $cmd eq $_ } @COMMANDS )
      { my $ips = Util::localhost_ips () ;
        $res = $ips ? not grep { $peer eq $_ } @$ips : 0 ;
      }
    $res ;
  }

sub zap_hist
  { OBB::A_is ( 2, scalar @_ ) ;
    my $self = shift ;
    my $hnam = shift ;
    my $hist = $self -> hist ;
    my $tnam = TS -> tnam ( $hnam ) ;
    my $res ;
    unless ( $hist )
      { $res = 'no hist' ; }
    elsif ( ! $hist -> has_tab ( $tnam ) )
      { $res = "no table $tnam" ; }
    else
      { $res = $hist -> zap ( $tnam, 3600, 60 * 60 * 24 * 32 ) ;
        $res = $hist -> zap ( $tnam,  900, 60 * 60 * 24 *  8 ) ;
        $res = $hist -> zap ( $tnam,  300, 60 * 60 * 24 *  2 ) ;
      }
    Util::as_text { resp => $res, data => {} } ;
  }

sub zap_old
  { OBB::A_is ( 3, scalar @_ ) ;
    my $self = shift ;
    my $name = shift ; # hnam or tnam
    my $keep = shift ;
    my $hist = $self -> hist ;
    my $tnam = TS -> tnam ( $name ) ;
    my $res ;
    unless ( $hist )
      { $res = 'no hist' ; }
    elsif ( ! $hist -> has_tab ( $tnam ) )
      { $res = "no table $tnam" ; }
    else
      { $res = $hist -> zap_old ( $tnam, $keep ) ; }
    Util::as_text { resp => $res, data => {} } ;
  }

# Client command ; must return undef for unknown command
sub command
  { my $self = shift ;
    my $cmd  = shift ;
    my $arg  = shift ;
    my $thrd = shift ;
    my $peer = $thrd -> inp -> peerhost ;
    my $res  ;
    if ( ! $self -> allow_command ( $cmd, $thrd ) )
      { $res = "command not allowed [$cmd] from $peer" ; }
    elsif ( $cmd eq 'STOP' )
      { my $STPR = $self -> conf -> read_stp || 'no secret' ;
        $res = ( ( $arg eq $STPR ) ? Client::STOPPED : 'BAD SECRET' ) ;
      }
    elsif ( $cmd eq 'SERVER' )
      { $res = $self -> do_server ( $arg, $thrd ) ; }
    elsif ( $cmd eq 'UPGRADE' )
      { $res = $self -> do_upgrade ( $arg, $thrd ) ; }
    elsif ( $cmd eq 'SEND' )
      { $res = $self -> do_send ( $arg, $thrd ) ; }
    elsif ( $cmd eq 'ZAP' )
      { $res = $self -> do_zap ( $arg, $thrd ) ; }
    elsif ( $cmd eq 'META' )
      { $res = $self -> do_meta ( $arg, $thrd ) ; }
    elsif ( $cmd eq 'HIST' )
      { $res = $self -> do_hist ( $arg, $thrd ) ; }
    elsif ( $cmd eq 'GETVAL' )
      { $res = $self -> do_getval ( $arg, $thrd ) ; }
    elsif ( $cmd eq 'SETVAL' )
      { $res = $self -> do_setval ( $arg, $thrd ) ; }
    $res ;
  }

# Client do_report
sub do_report
  { my $self = shift ;
    Util::as_text { resp => 'ok', state => $self -> state -> as_json } ;
  }

# Client do_send
sub do_send
  { my $self = shift ;
    sprintf "next_send %s %s"
      , Util -> hostname
      , scalar localtime $self -> next_send ( time + int rand 15 ) ;
  }

# arg == [ hnam ] ; default $self -> hnam
sub do_zap
  { my $self = shift ;
    my $arg  = shift ;
    my $thrd = shift ;
    my $hnam = shift || $self -> hnam ;
    $self -> zap_hist ( $hnam ) ;
  }

sub do_meta
  { my $self = shift ;
    my $arg  = shift ;
    my $thrd = shift ;
    my $hist = $self -> hist ;
    my $meta = {} ;
    my $resp ;
    if ( $hist )
      { for my $hnam ( $self -> state -> hnams )
          { my $tnam = $hist -> tnam ( $hnam ) ;
            OBB::TT 'do_meta %s', $hnam ;
            $meta -> { $hnam } =
              { count => $hist -> count ( $tnam )
              , first => $hist -> min ( $tnam, Dmon::TIME )
              , last  => $hist -> max ( $tnam, Dmon::TIME )
              } ;
          }
        $resp = sprintf 'ok meta' ;
      }
    else
      { $resp = sprintf "no history [%s]", $self -> hnam ; }

    Util::as_text { resp => $resp , data => $meta } ;
  }

# Client do_hist
# arg == [ [ival] [pnts] [host/table-name] [col ...] ]
# default ival : H
# default pnts : 100 == number of data-points
# default host : LOCAL == $self -> hnam
# default cols : hist.*
# returns data => { cols => [], rows => [] }
sub do_hist
  { my $self = shift ;
    my $arg  = shift ;
    my $thrd = shift ;
    my $hist = $self -> hist ;
    my @arg  = split ' ', $arg ;
    my $ival = shift @arg || 'H' ; $ival = uc substr $ival, 0, 1 ;
    my $pnts = shift @arg || 100 ;
    my $hnam = shift @arg || 'LOCAL' ;
    my %ival = () ;
    my %flat = () ;
    $ival { H } = 60 * 60 ;
    $ival { D } = 24 * $ival { H } ;
    $ival { W } =  7 * $ival { D } ;
    $ival { M } =  4 * $ival { W } + 3 * $ival { D } ;
    $ival { Y } = 52 * $ival { W } + 2 * $ival { D } ;
    $ival { A } = time ;
    $flat { H } = 60 ;
    $flat { D } = 10 * $flat { H } ;
    $flat { W } =  1 * $ival { H } ;
    $flat { M } =  4 * $ival { H } ;
    $flat { Y } =  2 * $ival { D } ;
    $flat { A } =  1 * $ival { W } ;
    unless ( $hist )
      { Util::as_text { resp => 'no hist', data => {} } ; }
    elsif ( ! $ival { $ival } )
      { Util::as_text { resp => "bad ival [$ival]", data => {} } ; }
    elsif ( $pnts !~ /^\d+$/ )
      { Util::as_text { resp => "pnts NaN [$pnts]", data => {} } ; }
    else
      { my $tnam = $hist -> tnam
          ( $hnam eq 'LOCAL' ? $self -> hnam : $hnam ) ;
        my $flat = $flat { $ival } ;
        my $colt = 'cast ( AVG ( TIME ) as int ) as TIMEx' ;
        my $grp  = "( TIME / $flat )" ;
        my @cols = ( @arg ? @arg : $hist -> user_cols ( $tnam ) ) ;
        my $tmin = time - $ival { $ival } ;
        my $col0 = '' ; $col0 = $cols [ 0 ] if @cols == 1 ;
        OBB::TT "tnam %s grp %s @cols", $tnam, $grp ;
        my $rows = $hist -> select
          ( $tnam
          , cols =>
              [ $colt
              , map { "SUM ( IVAL * $_ ) / SUM ( IVAL ) as $_" } @cols
              ]
          , where => "TIME >= $tmin"
              . ( $col0 ? " AND $col0 IS NOT NULL" : '' )
          , group_by => $grp
          , having   => '( COUNT(*) > 0 AND SUM ( IVAL ) > 0 )'
          ) ;
        my $rcnt = scalar @$rows ;
        my $err  = $hist -> Err ;
        my $resp = $err ? "no good: $err" : "ok rows $rcnt" ;
        Util::as_text
          { resp => $resp
          , data => { cols => [ Dmon::TIME, @cols ], rows => $rows }
          } ;
      }
  }

sub do_server
  { my $self = shift ;
    my $arg  = shift ;
    my $thrd = shift ;
    my $sndr = $self -> send_server ;
    return "can't connect to server" unless $sndr ;
    $thrd -> wait4 ( $sndr ) ;
    $sndr -> send ( $arg ) ;
  }

sub do_getval
  { my $self = shift ;
    my $arg  = shift ;
    my $thrd = shift ;
    my @args = split ' ', $arg ;
    my @hnams = $self -> state -> hnams ;
    my %Ivals = () ;
    my @Ivals = () ;
    for my $hnam ( @hnams )
      { for my $Item ( @{ $self -> state -> host_items ( $hnam ) } )
          { my $inam = $Item -> name ;
            my $val  = Util::diag ( $Item -> val ) ;
            $Ivals { $hnam } { $inam } = $val ;
            push @Ivals, "$hnam:$inam $val" ;
          }
      }
    my $hnam = 'localhost' ;
    my $inam = shift @args ;
    if ( ( $inam || '' ) =~ /:/ ) { $hnam = $` ; $inam = $' ; }
    $hnam = $Util::canonical_hostname if $hnam eq 'localhost' ;
    return "bad host $hnam in GETVAL $arg" unless exists $Ivals { $hnam } ;
    if ( defined $inam )
      { my $val = $Ivals { $hnam } { $inam } ;
        if ( defined $val )
          { "ok getval $hnam:$inam $val" ; }
        else
          { "bad item $inam in GETVAL $arg" ; }
      }
    else
      { join "\n", sort @Ivals ; }
  }

sub do_setval
  { my $self = shift ;
    my $arg  = shift ;
    my $thrd = shift ;
    my @args = split ' ', $arg ;
    return "usage : SETVAL [host:]item val" unless @args == 2 ;
    my $hnam = 'localhost' ;
    my $inam = shift @args ;
    my $val  = shift @args ;
    if ( $inam =~ /:/ ) { $hnam = $` ; $inam = $' ; }
    $hnam = $Util::canonical_hostname if $hnam eq 'localhost' ;
    return "bad host $hnam in SETVAL $arg"
      unless grep { $_ eq $hnam } $self -> state -> hnams ;
    my $Item =
      ( grep { $_ -> name eq $inam ; }
          @{ $self -> state -> host_items ( $hnam ) }
      ) [ 0 ] ;
    return "bad item $inam in SETVAL $arg" unless defined $Item ;
    return "val [$val] must be numeric in SETVAL $arg"
      unless $val =~ /^[-+]?\d+(\.\d+)?$/ ;
    my $probe = $Item -> probe -> name ;
    return "$inam.probe = $probe ; must be 'hist' in SETVAL $arg"
      unless $probe eq 'hist';
    $Item -> vtim ( 0 ) ;
    $self -> vals -> add_val ( $hnam, $inam, $val ) ;
    "ok setval $hnam:$inam $val"
  }

# Client do_upgrade
sub _upgrade
  { my $self = shift ;
    my $arg  = shift ;
    my $thrd = shift ;
    my $conf = $self -> conf ;
    my $prev  = Dmon -> Version ;
    my $path  = $conf -> bin_file ;
    my $pvar = Util::as_pvar ( $arg ) ;
    my $vers = $pvar -> {version} ;
    OBB::TT ( 'received new version %s', $vers ) ;
    return "identical version $vers" if $vers and $vers eq $prev ;
    OBB::TT ( 'sleep %s', sleep int rand 5 ) ;
    my $upgr = $conf -> upgr_mod ;
    $upgr = sprintf "%s::%s", $conf -> server, $upgr unless $upgr =~ /:/ ;
    my $rs = Util::rsync ( $upgr, $conf -> upgrdir ) || 'ok' ;
    unless ( $rs eq 'ok' )
      { return ( $rs =~ /^\d+$/ ? "rsync xit $rs" : $rs ) ; }
    else
      { my $mk = Util::run_make ( $conf -> upgrdir, 'upgrade' ) || 'ok' ;
        unless ( $mk eq 'ok' )
          { return ( $mk =~ /^\d+$/ ? "make xit $mk" : $mk ) ; }
      }
    sprintf 'ok %s -> %s', $prev, $vers || 'same' ;
  }

# Client do_upgrade
sub do_upgrade
  { my $self = shift ;
    my $res  = $self -> _upgrade ( @_ ) ;
    my $hnam = Util -> hostname ;
    my $ok   = $res =~ /^ok/ ;
    $self -> rexec ( time + 10 + int rand 60 ) if $ok ;
    sprintf "upgrade $hnam ... %s" , ( $ok ? $res : "fail\n  $res" ) ;
  }

# Client
sub STATE
  { my $self = shift ;
    ( ( sprintf "-- hostname %s\n", $self -> hnam )
    . ( sprintf "-- server   %s\n", $self -> server -> hnam )
    . ( sprintf "-- work     %s\n", scalar localtime $self -> work -> stamp )
    . ( sprintf "-- Client state :\n%s", $self -> state -> pretty )
    ) ;
  }

###################################################################
package Vals ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(hosts ) ) ;
sub Defs { ( hosts  => {} ) ; }

sub add_val
  { my $self = shift ;
    my $hnam = shift ;
    my $inam = shift ;
    my $val  = shift ;
    $self -> hosts -> { $hnam } { $inam } = $val ;
  }

sub del_val
  { my $self = shift ;
    my $hnam = shift ;
    my $inam = shift ;
    my $hsts = $self -> hosts ;
    my $res = delete $hsts -> { $hnam } { $inam } ;
    delete $hsts -> { $hnam } unless scalar keys %{ $hsts -> { $hnam } } ;
    $res ;
  }

sub cnt { scalar keys %{ $_[0] -> hosts -> { $_[1] } } ; }

###################################################################
package User ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(name mail) ) ;

sub xsrt { my $self = shift ; $self -> name ; }
sub work
  { my $self = shift ; { name => $self -> name, mail => $self -> mail } ; }

###################################################################
package Alert ;
use base qw(OBB) ;
__PACKAGE__ -> mk_getset ( qw(users levl1 levl2 hosts items) ) ;
sub Defs
  { ( users  => {}
    , levl1  => {}
    , levl2  => {}
    , hosts  => {}
    , items  => {}
    ) ;
  }

sub _in_level
  { my ( $self, $x, $lvl ) = @_ ;
    my $level = $self -> $lvl ;
    scalar keys %$level == 0 or $level -> { $x } || 0 ;
  }
sub in_1 { _in_level @_, 'levl1' ; }
sub in_2 { _in_level @_, 'levl2' ; }

sub users4
  { my $self = shift ;
    my $evnt = shift ;
    my $set  = Set -> Make ;
    my $old  = $evnt -> lold ; $old = -1 unless defined $old ;
    my $new  = $evnt -> lnew ; $new = -1 unless defined $new ;
    my $frm1 = $self -> in_1 ( $old ) ;
    my $frm2 = $self -> in_2 ( $old ) ;
    my $to1  = $self -> in_1 ( $new ) ;
    my $to2  = $self -> in_2 ( $new ) ;
    OBB::TT "old %s new %s frm1 %s frm2 %s to1 %s to2 %s"
      , $old, $new, $frm1, $frm2, $to1, $to2 ;
    return $set unless ( $frm1 and $to2 ) or ( $frm2 and $to1 ) ;
    my $hosts = $self -> hosts ;
    my $host  = $evnt -> hnam ;
    return $set if scalar keys %$hosts and ! $hosts -> { $host } ;
    my $items = $self -> items ;
    my $item  = $evnt -> item ;
    return $set if scalar keys %$items and ! $items -> { $item } ;
    my $users = $self -> users ;
    OBB::TT "users %s", scalar @$users ;
    $set -> add ( $_ ) for @$users ;
    $set ;
  }

###################################################################
package Event ;
use base qw(OBB) ;
__PACKAGE__ -> mk_getset ( qw(TIME hnam item lold lnew vold vnew mesg host) ) ;

sub SQL_ADD_COLS { qw(vold vnew) ; }

sub SQL_CREATE_TAB
  { my $self = shift ;
    my $tnam = shift ;
    my $res = <<SQL ;
CREATE TABLE $tnam
  ( TIME integer not null
  , hnam text not null
  , item text not null
  , lold integer
  , lnew integer
  , vold real
  , vnew real
  , mesg text
  , PRIMARY KEY ( TIME, hnam, item )
  )
SQL
    $res ;
  }

sub save
  { my $self = shift ;
    my $hist = shift ;
    $hist -> save_hash
      ( Dmon::T_EVNTS, OBB -> Unbless ( $self ), time, 1 ) ;
  }

sub users4
  { my $self   = shift ;
    my $alerts = shift ;
    my $set = Set -> Make ;
    for my $alert ( @$alerts )
      { $set -> union ( $alert -> users4 ( $self ) ) ; }
    $set -> list ;
  }

sub show_level
  { my $lvls = shift ;
    my $lvl  = shift ;
    my $levl = $lvls -> [ $lvl ] if defined $lvl ;
    ( defined $levl
    ? $levl -> show
    : sprintf "bad level (%s)", $lvl || 'undef'
    ) ;
  }

sub send_mail
  { my $self   = shift ;
    my $server = shift ;
    my $alerts = $server -> alerts ;
    my $levels = $server -> levels ;
    my @users  = $self -> users4 ( $alerts ) ;
    my $lold = show_level ( $levels, $self -> lold ) ;
    my $lnew = show_level ( $levels, $self -> lnew ) ;
    my $hnam = $self -> hnam ;
    my $show = $server -> show_client ( $hnam ) ;
    my $inam = $self -> item ;
    my $vold = $self -> vold ; $vold = 'undef' unless defined $vold ;
    my $vnew = $self -> vnew ; $vnew = 'undef' unless defined $vnew ;
    my $psec = $server -> conf -> page_sec ;
    my $href = "$psec?HOST=$hnam&amp;ITEM=$inam" ;
    my $wrks = $server -> works4 ( $hnam ) ;
    my $also = join "\n      ", @$wrks ;
    my $mesg = <<MESG ;
From: dmon\@science.uu.nl
Subject: [dmon] $lnew ; $inam on $show

Hi %s,

  FYI ; dmon found a fitness-change :

    host  : $show
    item  : $inam
    level : $lold => $lnew
    value : $vold => $vnew
    also  : $also

    $href

    <begin pgp signed message to disable safelinks/>

MESG
    for my $user ( @users )
      { my $name = $user -> name ;
        my $mail = $user -> mail ;
        Util::logt ( "user %s diag %s", $name, $self -> diag ) ;
        my $MAIL = Dmon::MAIL ;
        next unless -x $MAIL ;
        next if $server -> conf -> no_alert ;
        if ( open MAIL, '|-', $MAIL, '-t' )
          { print  MAIL "To: $mail\n" ;
            printf MAIL $mesg, ucfirst $name ;
            close  MAIL ;
          }
      }
  }

sub diag
  { my $self = shift ;
    sprintf 'hnam %s item %s lold %s lnew %s vold %s vnew %s'
      , Util::diag ( $self -> hnam )
      , Util::diag ( $self -> item )
      , Util::diag ( $self -> lold )
      , Util::diag ( $self -> lnew )
      , Util::diag ( $self -> vold )
      , Util::diag ( $self -> vnew )
      ;
  }

###################################################################
package Message ;
use base qw(OBB) ;
__PACKAGE__ -> mk_getset ( qw(TIME hnam item levl mesg host) ) ;

sub SQL_CREATE_TAB
  { my $self = shift ;
    my $tnam = shift ;
    my $res = <<SQL ;
CREATE TABLE $tnam
  ( TIME integer not null
  , hnam text not null
  , item text not null
  , levl integer DEFAULT 0
  , mesg text
  , PRIMARY KEY ( TIME, hnam, item )
  )
SQL
    $res ;
  }

sub save
  { my $self = shift ;
    my $hist = shift ;
    $hist -> save_hash
      ( Dmon::T_MESGS, OBB -> Unbless ( $self ), time, 1 ) ;
  }

sub lold { my $self = shift ; $self -> levl ; }
sub lnew { my $self = shift ; $self -> levl ; }

sub diag
  { my $self = shift ;
    sprintf 'hnam %s mesg %s'
      , Util::diag ( $self -> hnam )
      , Util::diag ( $self -> mesg )
      ;
  }

###################################################################
package State ;
use base qw(OBB) ;
__PACKAGE__ -> mk_getset ( qw(IVAL levels Items) ) ;
sub Defs { ( levels => [] ) ; }

use constant SEND_SERVER => [ qw(val vtim ival perr fitl) ] ;

sub PICK { my $itm = pop ; Util::slice ( $itm, @{+SEND_SERVER} ) ; }
sub RECV
  { my $self = shift ;
    my $item = shift ; # plain hash ; state from CLIENTS
    $item -> { fitl } =
      ( ( defined $item -> { fitl } )
      ? $self -> levels -> [ $item -> { fitl } ]
      : $Fitl::UNDF
      ) ;
    %$item ;
  }

###################################################################
package State::Client ;
use base qw(State) ;
__PACKAGE__ -> mk_getset ( qw(hosts) ) ;
sub Defs { ( hosts => {} ) ; }

# called by Client with
# work   => { hnam => { var => { ival fitr [args] }, ... } } ;
# IVAL   => $self -> DEF_IVAL
# levels => $self -> levels (as objects)
# Items  => $self -> Items
sub Init
  { my $self = shift ;
    my %opts = ( @_ ) ;
    $self -> State::Init ( %opts ) ;
    my $work  = $opts{work} ;
    my $hnams = $work -> hosts ;
    my $Items = $self -> Items ;
    for my $hnam ( sort keys %$hnams )
      { my $itms = $hnams -> { $hnam } ;
        $self -> hosts -> { $hnam } =
          [ map
              { # $_ is an item-name
                # keys $hash : fitr ival [args]
                my $hash = $itms -> { $_ } ;
                $hash -> {ival} ||= $self -> IVAL ;
                Item -> Make
                  ( $Items -> props ( $_ )
                  , hnam => $hnam
                  , lvls => $self -> levels
                  , %$hash
                  )
              }
            sort keys %$itms
          ] ;
      }
    $self ;
  }

# State::Client
sub hnams { my $self = shift ; sort keys %{ $self -> hosts } ; }
sub host_items
  { my $self = shift ; my $hnam = shift ; $self -> hosts -> { $hnam } ; }

# this goes to the server
sub as_json
  { my $self = shift ;
    my $hsts = $self -> hosts ;
    my $res  = {} ;
    for my $hnam ( sort keys %$hsts )
      { my $itms = $self -> hosts -> { $hnam } ;
        $res -> { $hnam } = {} ;
        for my $itm ( @$itms )
          { $res -> { $hnam } { $itm -> name } = $self -> PICK ( $itm ) ; }
      }
    $res ;
  }

sub as_text { my $self = shift ; Util::as_text ( $self -> as_json ) ; }
sub pretty  { my $self = shift ; Util::pretty ( $self ) ; }

# this goes into the database
sub hist_hash
  { my $self = shift ;
    my $hnam = shift ;
    my $hsts = $self -> hosts ;
    my $itms = $self -> hosts -> { $hnam } ;
    my $hash = {} ;
    for my $itm ( @$itms )
      { $hash -> { $itm -> name } = $itm -> val ; }
    $hash ;
  }

# State::Client
# return the number of items actually probed
sub mk_update
  { my $self = shift ;
    my $hnam = shift ; # host to probe
    my $clnt = shift ; # $main::CLIENT
    my $itms = $self -> hosts -> { $hnam } ;
    my %want = () ;
    my %prev = () ;
    my $cnt  = 0 ;
    for my $item ( sort { $a -> name cmp $b ->name } @$itms )
      { my $inam = $item -> name ;
        my $pnam = $item -> probe -> name ;
        my $time = $item -> vtim ;
        my $ival = $item -> ival ;
        unless ( $time && $ival && ( time < $time + $ival ) )
          { push @{ $want { $pnam } }, $item ;
            $prev { $inam } = [ $item, $item -> fitl, $item -> val ]
              if defined $time ;
            $item -> perr ( '' ) ;
            OBB::TT "want for $hnam $pnam $inam $ival" ;
            $cnt ++ ;
          }
      }
    for my $pnam ( sort keys %want )
      { OBB::TT "Probing $pnam ..." ;
        my $items = $want { $pnam } ;
        my $probe = $items -> [ 0 ] -> probe ;
        # pass the client for probe 'server'
        $probe -> main ( $items, $clnt ) ;
      }
    my $events = [] ;
    for my $tup ( values %prev )
      { my $item = shift @$tup ;
        my $fold = shift @$tup ;
        my $vold = shift @$tup ;
        my $fnew = $item -> fitl ;
        my $lold = defined $fold ? $fold -> levl : undef ;
        my $lnew = defined $fnew ? $fnew -> levl : undef ;
        my $vnew = $item -> val ;
        my $same =
          ( ( defined $lold and defined $lnew )
            ? ( $lold == $lnew )
            : ! ( defined $lold or defined $lnew )
          ) ;
        unless ( $same )
          { push @$events, Event -> Make
              ( hnam => $hnam
              , item => $item -> name
              , lold => $lold
              , lnew => $lnew
              , vold => $vold
              , vnew => $vnew
              ) ;
            OBB::TT "Events %s old %s new %s same %s vold %s vnew %s "
              , $item -> name, $lold, $lnew, $same, $vold, $vnew ;
           }
      }
    OBB::TT "Events %s", scalar @$events ;
    ( $cnt, $events ) ;
  }

###################################################################
package Pmaker ;
use base qw(Client) ;
__PACKAGE__ -> mk_getset
  ( qw(clients events event0 mesgs mesg0 alerts noalrt rejects) ) ;

use constant
  { PROG => 'dmon-pmaker'
  } ;

sub Init
  { my $self = shift ;
    OBB::TT 'Pmaker Init %s', $self ;
    $self -> Client::Init ( @_, SERVICE => 0 ) ;
    $self -> clients ( {} ) ;
    $self -> events  ( [] ) ;
    $self -> alerts  ( [] ) ;
    $self -> rejects ( Dmon::Rejects -> Make ) ;
    OBB::TT 'Pmaker Init levels %s', $self -> show_levels ;
    OBB::TT 'Pmaker Init done %s', $self ;
    $self ;
  }

sub PORT { my $self = shift ; $self -> conf -> port_pmaker ; }

sub mk_work
  { my ( $self, $lmod ) = @_ ;
    if ( $self -> hnam eq $self -> conf -> server )
      { Work::Pmaker -> make_from_file ( $self -> work_file, $lmod ) ; }
    else
      { Work::Pmaker -> make_from_serv ( $self, $lmod ) ; }
  }

# $dump == CLIENTS -> cdmp
sub get_clients
  { my $self = shift ;
    my $dump = shift ;
    for my $hnam ( keys %$dump )
      { my $data = $dump -> { $hnam } ;
        my $client = Host::Client -> Make ( %$data ) ;
        $self -> clients -> { $hnam } = $client ;
        my $state = State::Pmaker -> Make
          ( host   => $client
          , IVAL   => $self -> DEF_IVAL
          , levels => $self -> levels
          , Items  => $self -> Items
          ) ;
        $client -> state ( $state ) ;
      }
  }

sub get_events
  { my $self = shift ;
    my $dump = shift ;
    $self -> events ( [ map { Event -> Make ( %$_ ) } @$dump ] ) ;
  }

sub get_messages
  { my $self = shift ;
    my $dump = shift ;
    $self -> mesgs  ( [ map { Message -> Make ( %$_ ) } @$dump ] ) ;
  }

sub show_hnam
  { my $self = shift ;
    my $hnam = shift ;
    my $host = $self -> clients -> { $hnam } ;
    $host ? $host -> show : "no host $hnam" ;
  }

###################################################################
package State::Pmaker ;
use base qw(State) ;
__PACKAGE__ -> mk_getset ( qw(host items) ) ;
sub Defs { ( items => {} ) ; }

# called by Pmaker with
# host   => { ..., state => { var => { val => ??, ... } } } ;
# IVAL   => $self -> DEF_IVAL
# levels => $self -> levels
# Items  => $self -> Items
sub Init
  { my $self = shift ;
    my %opts = ( @_ ) ;
    $self -> State::Init ( %opts ) ;
    my $Items = $self -> Items ;
    my $host  = $self -> host ;
    my $state = $host -> state ;
    my $items =
      [ # $_ is an item_name
        map
          { Item -> Make
              ( $Items -> props ( $_ )
              , $self  -> RECV ( $state -> { $_ } )
              , hnam   => $host -> hnam
              )
          }
        sort keys %$state
      ] ;
    $self -> items ( $items ) ;
    $self ;
  }

sub by_name
  { my $self = shift ;
    my $name = shift ;
    ( grep { $_ -> name eq $name } @{ $self -> items } ) [ 0 ] ;
  }

###################################################################
package Work ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(items error stamp) ) ;
sub Defs { ( items => [], stamp => 0 ) ; }

sub Init { my $self = shift ; $self ; }

sub make_from_file
  { my $self = shift ;
    my $file = shift ;
    my $lmod = shift ;
    my $res  = $self -> Make ;
    my $lm   = ( stat $file ) [ 9 ] ;
    unless ( defined $lm )
      { $res -> stamp ( 0 ) ;
        $res -> error ( "no stat $file ($!)" ) ;
      }
    elsif ( $lmod )
      { $res -> stamp ( $lm ) ; }
    elsif ( open FILE, '<', $file )
      { my $pvar = Util::as_pvar ( join '', <FILE> ) ;
        close FILE ;
        $res -> Init ( %$pvar, stamp => $lm ) ;
      }
    else
      { $res -> error ( "no open $file ($!)" ) ;
        OBB::TT "can't make_from_file %s", $res -> error ;
      }
    $res ;
  }

# returns undef on "can't connect"
sub make_from_serv
  { my $self = shift ;
    my $clnt = shift ;
    my $lmod = shift ;
    my $mesg = $clnt -> get_work_mesg ( $lmod ) ;
    my $res  = $self -> Make ;
    if ( $mesg )
      { # first Init ; because is sets defaults
        unless ( $lmod )
          { my $work = $mesg -> work || {} ;
            $res -> Init ( %$work ) ;
          }
        $res -> error ( $mesg -> resp ) if $mesg -> err ;
        $res -> stamp ( $mesg -> lm || 0 ) ;
      }
    else
      { $res = $self -> IDLE ;
        OBB::TT "can't make_from_serv %s", $res -> error ;
      }
    $res ;
  }

sub IDLE  { undef ; }
sub _hnam { my $x = shift ; $x -> {hnam} ; }
sub _show { my $x = shift ; $x -> {show} ; }
sub _wrkr { my $x = shift ; $x -> {wrkr} ; }

###################################################################
package Work::Server ;
use base 'Work' ;
__PACKAGE__ -> mk_getset ( qw(hosts users alerts levels pmaker) ) ;

sub Init
  { my $self = shift ;
    $self -> hosts ( [] ) ;
    $self -> levels  ( '' ) ;
    $self -> OBB::Init ( @_ ) ;
    $self ;
  }

sub IDLE { my $self = shift ; $self -> Make ; }

# Work::Server
sub hnams
  { my $self = shift ;
    [ map { Work::_hnam $_ } @{ $self -> hosts } ] ;
  }

sub wrkrs
  { my $self = shift ;
    [ map { Work::_hnam $_ } grep { ! $_ -> {wrkr} } @{ $self -> hosts } ] ;
  }

###################################################################
package Work::Client ;
use base 'Work' ;
__PACKAGE__ -> mk_getset ( qw(hosts levels lm) ) ;

sub Init
  { my $self = shift ;
    $self -> hosts   ( {} ) ;
    $self -> levels  ( '' ) ;
    $self -> OBB::Init ( @_ ) ;
    $self ;
  }

sub IDLE { my $self = shift ; $self -> Make ; }

###################################################################
package Work::Pmaker ;
use base 'Work::Client' ;
__PACKAGE__ -> mk_getset ( qw(alerts xargs xfits) ) ;

sub have_host
  { my $self = shift ;
    my $hnam = shift ;
    $self -> hosts -> { $hnam } ;
  }

sub xargs_item
  { my $self  = shift ;
    my $item  = shift ;
    my $xargs = $self -> xargs ;
    my $res = {} ;
    for my $h ( sort keys %$xargs )
      { if ( exists $xargs -> { $h } -> { $item } )
          { $res -> { $h } = join ' ', @{ $xargs -> { $h } -> { $item } } ; }
      }
    $res ;
  }

sub xfits_item
  { my $self  = shift ;
    my $item  = shift ;
    my $xfits = $self -> xfits ;
    my $res = {} ;
    for my $h ( grep $_ ne 'DEFAULT', sort keys %$xfits )
      { if ( exists $xfits -> { $h } -> { $item } )
          { $res -> { $h } = $xfits -> { $h } -> { $item } ; }
      }
    $res ;
  }

sub defaults { my $self = shift ; $self -> xfits -> { DEFAULT } ; }

sub dftr
  { my $self = shift ;
    my $name = shift ;
    $self -> defaults -> { $name } ;
  }

sub hftr
  { my $self = shift ;
    my $hnam = shift ;
    my $name = shift ;
    ( exists $self -> xfits -> { $hnam }
    ? $self -> xfits -> { $hnam } -> { $name }
    : $self -> defaults -> { $name }
    ) ;
  }

###################################################################
package Conf ;
use base 'OBB' ;

use constant FILES => ( 'dmon.conf', Dmon::CDIR . '/conf' ) ;
use constant
  { LOGFILE => 'dmon.log'
  , PIDFILE => 'dmon.pid'
  , LCKFILE => 'dmon.lck'
  , STPFILE => 'dmon.stp'
  , DBSFILE => 'data.lite'
  } ;

our @FILES = FILES ;
our %DEF_CONF =
  ( PORT => 22007
  , save => Dmon::CDIR . '/save'
  , html => Dmon::CDIR . '/html'
  , ival_make_state  =>  60
  , ival_send_report => 300
  , ival_check_work  => 600
  , ival_keep_events => '4w'
  , ival_keep_mesgs  => '4w'
  , ival_show_events => '1d'
  , bindir => '/usr/sbin'
  , logdir => '/var/log/dmon'
  , vardir => '/var/dmon'
  , rundir => '/var/run/dmon'
  , lckdir => '/var/lock/subsys'
  , loglvl => 'Terse'
  , rotate => '8 1d'
  , server => undef
  , domain => undef
  , hostname => undef
  , page_sec => '/cgi-bin/gen-dmon-page'
  , plot_url => '/plotter.php'
  , httpdgid => undef
  , upgr_mod => 'dmon-upgrade'
  ) ;

__PACKAGE__ -> mk_getset ( 'file', keys %DEF_CONF ) ;

sub Init
  { my $self = shift ;
    my %opts = ( @_ ) ;
    $self -> OBB::Init ( %DEF_CONF, %opts ) ;
    my $optc = $opts { file } ;
    my $file = _use_file ( $optc || @FILES ) ;
    $self -> file ( $file ) ;
    $self -> Die
      ( $optc
      ? "can't find dmon config file [$optc]"
      : sprintf "no dmon config found [%s]", join ',', @FILES
      ) unless defined $file ;
    $self -> _get_conf ( $file ) ;
    $self -> _check ;
    $self ;
  }

sub _use_file
  { for my $cand ( @_ ) { return $cand if defined $cand and -f $cand ; }
    undef ;
  }

sub _get_conf
  { my $self = shift ;
    my $path = shift ;
    open CONF, '<', $path or OBB -> Die ( "can't open $path ($!)" ) ;
    my @lines = <CONF> ;
    close CONF ;
    for my $line ( @lines )
      { chomp $line ;
        next if $line =~ /^#/ ;
        next if $line =~ /^\s*$/ ;
        my ( $key, $val ) = split ' ', $line, 2 ;
        $self -> Die ( "missing value for key $key\n" ) unless defined $val ;
        $self -> Die ( "bad key '$key'\n" )
          unless $key eq 'include' or exists $DEF_CONF { $key } ;
        $self -> Die ( "Conf can't '$key'\n" ) unless $self -> can ( $key ) ;
        $self -> $key ( $val ) ;
      }
  }

sub include
  { my $self = shift ;
    my $path = shift ;
    $self -> _get_conf ( $path ) ;
  }

sub _check
  { my $self = shift ;
    my $hnam = $self -> hostname ;
    my $serv = $self -> server ;
    my $cdom = $self -> domain ;
    my $bnam = Util -> bin_hostname ;
    OBB::TT ( 'Util -> bin_hostname() %s', $bnam ) ;
    if ( defined $hnam )
      { Util -> hostname_set ( $hnam, $cdom ) ; }
    elsif ( $cdom and $bnam and $bnam !~ /\./ )
      { my $was = Util -> hostname || 'no_hostname' ;
        my $now = Util -> hostname_set ( $bnam, $cdom ) ;
        print "Conf: set hostname $was => $now\n" if OBB -> Verbose ;
      }
    $self -> Die ( "Conf: no 'server'\n" ) unless defined $serv ;
    my $cnam = Util -> hostname_make ( $serv, $cdom ) ;
    unless ( $serv eq $cnam )
      { print "Conf: set server $serv => $cnam\n" if OBB -> Verbose ;
        $serv = $self -> server ( $cnam ) ;
      }
    my $llvl = $self -> loglvl ;
    $self -> Die ( "Conf: bad loglvl [$llvl]\n" ) unless $OBB::VLVLS{$llvl} ;
    # check rotate
      { my $rotl = $self -> rotate ;
        my ( $num, $spc ) = split ' ', $rotl ;
        $self -> Die ( "Conf: bad rotate [$rotl]\n" ) unless defined $spc ;
        $self -> Die ( "Conf: bad number in rotate [$rotl]\n" )
          unless $num =~ /^\d+$/ ;
        $self -> Die ( "Conf: bad spec in rotate [$rotl]\n" )
          unless defined Util::secs4spec ( $spc ) ;
      }
    my @ivals = qw(send_report check_work keep_events keep_mesgs show_events) ;
    for my $opt ( map "ival_$_", @ivals )
      { my $spec = $self -> $opt ;
        my $secs = Util::secs4spec ( $spec ) ;
        $self -> Die ( "Conf: bad spec in $opt [$spec]\n" )
          unless defined $secs ;
        $self -> $opt ( $secs ) ;
      }
    # fix PATH
      { my $path = $ENV { PATH } ;
        my @path = split /:/, $path ;
        my %path = map { ( $_ => 1 ) } @path ;
        my $prbs = $self -> prbsdir ;
        for my $dir ( qw(/sbin /usr/sbin) )
          { $path .= ":$dir" unless $path { $dir } ; }
        for my $dir ( qw(/local/bin) )
          { $path = "$dir:$path" unless $path { $dir } ; }
        $ENV { PATH } = "$prbs:$path" ;
      }
  }

sub workdir { sprintf '%s/%s', $_[0] -> vardir, Dmon::WORK ; }
sub upgrdir { sprintf '%s/%s', $_[0] -> vardir, Dmon::UPGR ; }
sub prbsdir { sprintf '%s/%s', $_[0] -> vardir, Dmon::PRBS ; }
sub secrfil { sprintf '%s/%s', $_[0] -> vardir, Dmon::SECR ; }
sub cgidata { sprintf '%s/%s', $_[0] -> vardir, Dmon::CGID ; }

sub log_file { sprintf '%s/%s', $_[0] -> logdir, LOGFILE ; }
sub pid_file { sprintf '%s/%s', $_[0] -> rundir, PIDFILE ; }
sub lck_file { sprintf '%s/%s', $_[0] -> rundir, LCKFILE ; }
sub stp_file { sprintf '%s/%s', $_[0] -> rundir, STPFILE ; }
sub dbs_file { sprintf '%s/%s', $_[0] -> vardir, DBSFILE ; }
sub dbs_pmkr { sprintf '%s/%s', $_[0] -> cgidata, DBSFILE ; }
sub log_pmkr { sprintf '%s/%s', $_[0] -> cgidata, LOGFILE ; }

# config option 'bindir' is ignored by 'root'
sub bin_file
  { ( $< ? ( sprintf '%s/%s', $_[0] -> bindir, Dmon::PROG ) : Dmon::PATH ) ; }
sub upgr_file { sprintf '%s/%s', $_[0] -> upgrdir, Dmon::PROG ; }

sub port_server { $_[0] -> PORT ; }
sub port_client { $_[0] -> PORT + 1 ; }
sub port_pmaker { 0 ; }

# protocol
# no arg         : no_alert status
# arg == 0       : no_alert reset
# arg =~ /^\w+$/ : no_alert set by $1
sub no_alert
  { my $self = shift ;
    my $file = sprintf '%s/%s', $self -> vardir, Dmon::NO_ALRT ;
    if ( @_ )
      { my $arg = shift ;
        if ( $arg )
          { open FILE, '>', $file ; print FILE $arg ; close FILE ; }
        else
          { unlink $file ; }
      }
    -f $file ? `cat $file` : 0 ;
  }

sub _make_secr
  { my $res = '' ;
    my @abc = ( 'a' .. 'z' ) ;
    for my $i ( 1 .. 12 ) { $res .= $abc [ int rand ( 26 ) ] ; }
    $res ;
  }

sub make_stp
  { my $self = shift ;
    my $file = $self -> stp_file ;
    if ( open STOP, ">$file" )
      { printf STOP "%s\n", _make_secr ;
        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 own_stp { my $self = shift ; ( stat $self -> stp_file ) [ 4 ] ; }

sub sys_lock
  { sprintf "%s/%s", $_[0] -> lckdir, Dmon::PROG ; }
sub make_sys_lock
  { my $res = 0 ;
    if ( open SYSLOCK, ">>", $_[0] -> sys_lock )
      { close SYSLOCK ; $res = 1 ; }
    $res ;
  }
sub rm_sys_lock { unlink $_[0] -> sys_lock ; }

sub rot_cnt { my $self = shift ; ( split ' ', $self -> rotate ) [ 0 ] ; }
sub rot_spc { my $self = shift ; ( split ' ', $self -> rotate ) [ 1 ] ; }
sub rot_ivl { my $self = shift ; Util::secs4spec ( $self -> rot_spc ) ; }
sub zap_ivl { my $self = shift ; 60 * 60 ; }

###################################################################
package Set ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(name mems) ) ;
sub Defs { ( name => 'set', mems => {} ) ; }

sub compare
  { my $aa = ( ref $a and $a -> can ( 'xsrt' ) ) ? $a -> xsrt : $a ;
    my $bb = ( ref $b and $b -> can ( 'xsrt' ) ) ? $b -> xsrt : $b ;
    $aa cmp $bb ;
  }
sub size { my $self = shift ; scalar keys %{ $self -> mems } ; }
sub xsrt { my $self = shift ; $self -> name ; }
sub list { my $self = shift ; sort compare values %{ $self -> mems } ; }
sub is_empty { my $self = shift ; ! $self -> list ; }
sub _utag
  { my $x = shift ;
    ( ref ( $x ) and $x -> can ( 'utag' ) ) ? $x -> utag : $x ;
  }
sub add
  { my $self = shift ;
    $self -> {mems} { _utag $_ } = $_ for @_ ;
    $self ;
  }
sub del
  { my $self = shift ; delete $self -> {mems} { _utag $_ } for @_ ; $self ; }
sub union
  { my $this = shift ;
    my $that = shift ;
    $this -> add ( $that -> flat -> list ) ;
    $this ;
  }
sub minus
  { my $this = shift ;
    my $that = shift ;
    $this -> del ( $that -> flat -> list ) ;
    $this ;
  }
sub any
  { my $self = shift ;
    ( $self -> list ) [ 0 ] ;
  }

sub flat
  { my $self = shift ;
    my @incl = @_ ;
    my $res  = Set -> Make ( name => 'flat_' . $self -> name ) ;
    if ( grep $self == $_, @incl )
      { OBB -> Xit
          ( 'bad recursion: %s'
          , join ' -> ', map { $_ -> name } @incl, $self
          ) ;
      }
    for my $elem ( $self -> list )
      { if ( ref ( $elem ) =~ /Set/ )
          { $res -> add ( $elem -> flat ( @incl, $self ) -> list ) ; }
        else
          { $res -> add ( $elem ) ; }
      }
    $res ;
  }

###################################################################
package Kind ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(name dscr suff stor show) ) ;

sub utag  { my $self = shift ; $self -> name ; }
sub xsrt  { my $self = shift ; $self -> name ; }

our $NO_KIND = Kind -> Make ( name => 'kind_no_kind' ) ;

###################################################################
package Kinds ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw() ) ;

my $_KINDS = <<KINDS ;
days , time span in days , days   , int [seconds]  , X / 86400
gbs  , Gigabytes         , GB     , int [KBytes]   , X / 1024 / 1024
int  , integer           ,        , int            , X
msec , milliseconds      , ms     , real [seconds] , X &times; 1000
perc , percentage        , %      , real           , X
real , real              ,        , real           , X
secs , seconds           , s      , int [seconds]  , X
spin , up or down        ,        , int            , X == 0 ? down : up
temp , temperature       , &deg;C , real           , X
volt , voltage           , Volt   , real           , X
KINDS

our $KINDS = __PACKAGE__ -> Make ;

sub Init
  { my $self = shift ;
    for my $line ( grep /./, split "\n", $_KINDS )
      { my ( $name, @rec ) = map { s/^\s+// ; s/\s+$// ; $_ ; }
          split /\s*,\s*/, $line ;
        my $kind = Kind -> Make ( name => $name ) ;
        $kind -> $_ ( shift @rec ) for qw(dscr suff stor show) ;
        $self -> { $name } = $kind ;
      }
    $self ;
  }

sub kind
  { my $self = shift ;
    my $kind = shift ;
    $KINDS -> { $kind } || $Kind::NO_KIND ;
  }

sub list
  { my $self = shift ;
    [ sort { $a -> xsrt cmp $b -> xsrt } values %$self ] ;
  }

###################################################################
package Dmon::Test ;
# X : curr value
# L : prev level
# UP L1, L2, ... Ln
# UP L1, L2, ... Ln DOWN L1, L2, ... Lx
# UP L1, L2, ... Ln DOWN DECR d ==
# UP L1, L2, ... Ln DOWN L1 - d, L2 - d, ...
# UP(x) <= UP(y) for x <= y
# DN(x) <= DN(y) for x <= y
# UP(x) <= DN(x) for all x
 
# LV(X) := ( UP(X) < DN(X) && UP(X) <= L <= DN(X) } ? L : UP(X)

#           +---DN----+---UP-----------------
#           |         |                     
#           DN        UP                    
#           |         |                     
# ----------+---UP----+----------------------
#          C-d        C                     

our $_X ;
our $_L ;

sub comp
  { my ( $list, $x ) = @_ ;
    my $res ;
    for ( my $i = 0 ; $i < @$list ; $i ++ )
      { if ( $_X < $list -> [ $i ] ) { $res = $i ; last ; } }
    defined ( $res ) ? $res : @$list + 1 ;
  }

sub UP
  { my @args = @_ ;
    my $x = $_X ;
    my $l = $_L ;
    return 0 unless @args ;
    my $down = [] ; $down = pop @args if ref $args [ $#args ] ;
    my $up   = [ @args ] ;
    if ( @$down and ref $down -> [ $#$down ] )
      { my $last = pop @$down ;
        my $decr = $last -> [ 0 ] || 1 ;
        @$down = map { $_ - $decr } @$up ;
      }
    my $up_x = comp ( $up, $x ) ;
    my $dn_x = comp ( $down, $x ) ;
    OBB::TT ( "  X %s l %s up_x %s dn_x %s", $x, $l, $up_x, $dn_x ) ;
    my $res ;
    if ( defined $l and $up_x < $dn_x and $up_x <= $l and $l <= $dn_x )
      { $res = $l ;
        OBB::TT ( "  use hyst %s %s", $x, $res ) ;
      }
    else
      { $res = $up_x ;
        OBB::TT ( "  not hyst %s %s", $x, $res ) ;
      }
    $res ;
  }
sub DOWN { [ @_ ] ; }
sub DECR { [ @_ ] ; }

###################################################################
package Item ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset
  ( qw(name kind probe args hnam val vtim ival perr lvls fitr fitl src) ) ;
sub Defs { ( src => Dmon::SRC_DEF ) ; } ;

sub Init
  { my $self = shift ;
    my %opts = ( @_ ) ;
    $self -> OBB::Init ( %opts ) ;
    $self ;
  }

sub utag  { my $self = shift ; $self -> name ; }
sub xsrt  { my $self = shift ; $self -> name ; }

sub fit
  { my $self = shift ;
    my $fitl = $self -> fitl ;
    defined ( $fitl ) ? $fitl -> name : 'no fitl' ;
  }
sub levl
  { my $self = shift ;
    my $fitl = $self -> fitl ;
    $fitl ? $fitl -> levl : defined $self -> val ? 0 : undef ;
  }

sub suff
  { my $self = shift ; $Kinds::KINDS -> kind ( $self -> kind ) -> suff ; }

sub Repr
  { my $self = shift ;
    my $suff = $self -> suff ;
    if ( @_ )
      { my $res = shift ; $suff ? "$res $suff" : "$res" ; }
    else
      { my $res = $self -> name ; $suff ? "$res [$suff]" : $res ; }
  }

# $item -> repr shows $item -> val ;
# $item -> repr ( $val ) shows $val
sub repr
  { my $self = shift ;
    my $val  = @_ ? shift : $self -> val  ;
    my $name = $self -> name ;
    my $kind = $self -> kind ;
    my $res  = $val ;
    my $sty  ;
    unless ( defined $val )
      { $res = 'undef' ; $sty = 'brb' ; }
    elsif ( $kind eq 'spin' )
      { $res = $val ? 'up' : 'down' ;
        $sty = 'brb' if $res eq 'down' ;
      }
    elsif ( $kind eq 'perc' )
      { $res = sprintf "%.2f", $res ; }
    elsif ( $kind eq 'gbs' )
      { $res = sprintf "%.2f", $res / 1024 / 1024 ; }
    elsif ( $kind eq 'days' )
      { $res = sprintf "%.2f", $res / 3600 / 24 ; }
    elsif ( $kind eq 'msec' )
      { $res = sprintf "%.3f", 1000 * $res ; }
    elsif ( $kind eq 'int' )
      { $res = sprintf "%d", $res ; }
    elsif ( $kind eq 'real' )
      { $res = sprintf "%.3f", $res ; }
    elsif ( $kind eq 'date' )
      { $res = Util::date ( $res ) ; }
    $sty ? main::SPAN ( $res, $sty ) : $res ;
  }

sub set_val
  { my $self = shift ;
    my $val  = shift ;
    OBB::TT ( '  item %s val %s', $self -> name, $val ) ;
    $self -> vtim ( time ) ;
    $self -> set_val_fitl ( $val ) ;
    $self -> add_perr ( 'err_undefined' ) unless defined $val ;
  }

sub add_perr
  { my $self = shift ;
    my $msg  = shift ;
    my $perr = $self -> perr ;
    $perr .= "\n" if defined $perr and length $perr ;
    $self -> perr ( $perr . $msg ) ;
  }

sub set_fit
  { my $val  = shift ;
    my $prv  = shift ; # previous level
    my $cons = shift ;
    my $fitr = shift ;
    my $res  ;
    my $err  ; # only for the expr-check
    OBB::TT ( '  fitr %s', $fitr ) if defined $fitr ;
    OBB::TT ( '  set_fit val %s', $val ) ;
    unless ( $fitr )
      { $res = 0 ; }
    elsif ( ! defined $val )
      { $res = undef ; }
    else
      { $cons -> { X } = $val ;
        $cons -> { L } = ( defined $prv ? $prv : 'undef' ) ;
        $Dmon::Test::_X = $val ;
        $Dmon::Test::_L = $prv ;
        my $undf = join "; \n", map { "undef *Dmon::Test::$_" } keys %$cons ;
        my $cstr = sprintf "use constant\n  { %s }", join ', ',
          map { sprintf "%s => %s", $_, $cons -> { $_ } } keys %$cons ;
        my $eval = <<EVAL ;
package Dmon::Test ;
use strict ;
$undf ;
$cstr ;
$fitr ;
EVAL
#       print $eval ;
        $res = eval $eval ;
        $err = $@ ;
      }
    OBB::TT "  set_fit res %s", $res if defined $fitr ;
    OBB::TT "  set_fit err %s", $err if $err ;
    ( $res, $err ) ;
  }

sub set_val_fitl
  { my $self = shift ;
    my $val  = shift ;
    my $prv  = $self -> levl ;
    my $lvls = $self -> lvls ;
    my $fitr = $self -> fitr ;
    my $fit  = $lvls -> [ 0 ] ;
    if ( $fitr )
      { my $cons = { map { ( $_ -> name => $_ -> levl ) } @$lvls } ;
        my ( $lvl, $err ) = set_fit $val, $prv, $cons, $fitr ;
        if ( defined $lvl )
          { my $max = @$lvls - 1 ;
            $lvl = $max if $lvl > $max ;
            $fit = $lvls -> [ $lvl ]
          }
      }
    $self -> val ( $val ) ;
    $self -> fitl ( $fit || $Fitl::UNDF ) ;
  }

sub check_fit
  { my $self = shift ;
    my $cons = shift ;
    my $fitr = shift ;
    my $val  = 22 ;
    # last '1' makes set_fit return $err
    my ( $lvl, $err ) = set_fit ( $val, $val, $cons, $fitr ) ;
    $err ;
  }

sub diag
  { my $self = shift ;
    sprintf "%s for %s"
      , Util::diag ( $self -> name )
      , Util::diag ( $self -> hnam ) ;
  }

###################################################################
package Items ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(conf hash) ) ;
sub Defs { ( hash => {} ) ; }

use constant MAKE_WORK => [ qw(client_cnt clients_ok) ] ;

sub Init
  { my $self = shift ;
    $self -> OBB::Init ( @_ ) ;
    $self -> require_pms ;
    $self ;
  }

sub require_pms
  { my $self = shift ;
    Carp::confess 'here' unless defined $self -> conf ;
    my $pdir = $self -> conf -> prbsdir ;
    my @pms  = <$pdir/*/*.pm> ;
    for my $pm ( @pms )
      { $pm =~ m!^(.*)/(.*).pm$! ;
        my $path = $1 ;
        my $pack = "Probe::$2" ;
        my $name = lc $2 ;
        eval "require '$pm'" ;
        OBB::TT ( 'require %s', $pm ) ;
        if ( $@ )
          { OBB::logq ( $@ ) ; exit ; }
        elsif ( $pack -> can ( 'ITEMS' ) )
          { my $items = $pack -> ITEMS ;
            my $probe = $pack -> Make ( name => $name, path => $path ) ;
            $probe -> Dmp ( "probe $pm" ) if $self -> Debug ;
            for my $item ( @$items )
              { $self -> add ( probe => $probe, %$item ) ; }
            Probes -> add ( $name, $probe ) ;
          }
        else
          { OBB::logq ( "$pm : pack [$pack] can't do ITEMS\n" ) ; }
      }
  }

sub add
  { my $self = shift ;
    my $item = Item -> Make ( @_ ) ;
    $self -> hash -> { $item -> name } = $item ;
    my $item_probe = $item -> probe ;
    my $list_probe = Probes -> has ( $item_probe ) ;
    if ( ! ref $item_probe and ref $list_probe )
      { $item -> probe ( $list_probe ) ; }
  }

sub add_items
  { my $self = shift ; my $itms = shift ; $self -> add ( %$_ ) for @$itms ; }

sub list
  { my $self = shift ;
    my $hash = $self -> hash ;
    sort { $a -> name cmp $b -> name } values %$hash ;
  }

sub have
  { my $self = shift ;
    my $name = shift ;
    $self -> hash -> { $name } ;
  }

sub _no_item
  { my $self = shift ;
    my $name = shift ;
    Item -> Make
      ( name => $name, qw(kind no_kind probe no_probe), args => [] ) ;
  }

sub item
  { my $self = shift ;
    my $name = shift ;
    $self -> hash -> { $name } || $self -> _no_item ( $name ) ;
  }

sub props
  { my $self = shift ; my $name = shift ; %{ $self -> item ( $name ) } ; }

# for gen-dmon-page
sub probes
  { my $self = shift ;
    Util::uniq map $_ -> probe, values %{ $self -> hash } ;
  }

###################################################################
package Probe ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(name path) ) ;

###################################################################
package Probe::Result ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(err xit sig lines) ) ;
sub Defs { ( lines => [] ) ; }

sub bad { my $self = shift ; $self -> err or $self -> xit or $self -> sig ; }

###################################################################
package Probe::Util ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset () ;

sub run_prog
  { my ( $prog, @args ) = @_ ;
    my ( $err, $xit, $sig ) ;
    my $lines = [] ;
    OBB::TT "  running %s %s", $prog, join ' ', map "\"$_\"", @args ;
    if ( ! -f $prog )
      { $err = "can't find $prog" ; }
    else
      { my ( $pid, $pipe ) = Util::mk_pipe ( $prog, @args ) ;
        @$lines = <$pipe> ;
        unless ( $pipe -> close )
          { $err = "can't close pipe" ; }
        else
          { waitpid $pid, 0 ;
            $xit = $? >> 8 ;
            $sig = $? & 127 ;
            if ( $sig )
              { my $nam = Util::sig_name ( $sig ) ;
                $err = $nam eq 'ALRM' ? 'TIMEOUT' : "sig [$nam]" ;
              }
            elsif ( $xit )
              { $err = "xit [$xit]" ; }
          }
      }
    OBB::TT "  err %s xit %s sig %s lines %s"
      , $err, $xit, $sig, scalar @$lines ;
    ( wantarray
    ? ( $err, $xit, $sig, @$lines )
    : Probe::Result -> Make
        ( err => $err, xit => $xit, sig => $sig, lines => $lines )
    ) ;
  }

# expire=201710091339

sub secs_expire
  { my $date = shift ;
    my $secs = 0 ;
    OBB::TT "  expire date %s", $date ;
    if ( $date =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})/ )
      { my $yea = $1 - 1900 ;
        my $mon = $2 - 1 ;
        my $day = $3 ;
        my $hr  = $4 ;
        my $min = $5 ;
        OBB::TT "  expire yea %s mon %s day %s", $yea, $mon, $day ;
        my $time = Time::Local::timegm ( 12, $min, $hr, $day, $mon, $yea ) ;
        $secs = $time - time ;
        OBB::TT "  expire time %s secs %s", $time, $secs ;
        $secs = 0 if $secs < 0 ;
      }
    OBB::TT "  expire res %s", $secs ;
    $secs ;
  }

###################################################################
# Probes are called as $probe ( $want, $clnt )
# -- with %$want = { var => $item, ... }
# -- where $clnt wants ( var, ... ) for $hnam ( $item -> hnam ) ;

package Probes ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw() ) ;

our $PROBES = {} ;

sub add { my ( $self, $name, $probe ) = @_ ; $PROBES -> { $name } = $probe ; }
sub has { my ( $self, $name ) = @_ ; $PROBES -> { $name } ; }

###################################################################
package Fitl ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(name show levl) ) ;

our $UNDF = Fitl -> Make
  ( name => 'undf'
  , show => 'undefined'
  , levl => 999
  ) ;
sub UNDF { $UNDF ; }

sub xsrt { my $self = shift ; $self -> levl ; }
sub exp  { my $self = shift ; $self -> levl ; }

sub mk_levels
  { my $self = shift ;
    my $lvls = shift ;
    my $cnt  = 0 ;
    [ map
        { $self -> Make
            ( name => substr ( $_, 0, 4 )
            , show => $_
            , levl => $cnt ++
            )
        } split ' ', $lvls
    ] ;
  }

###################################################################
package Buff ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw() ) ;

use constant BUF_SIZE => 65536 ;

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 )
      { 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 diag
  { my $self = shift ; sprintf "$self\n  %s", Util::diag ( $self -> get ) ; }

# Buff
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} ) ;
  }

##############################################################
package Threads ;
use base 'OBB' ;
OBB -> import ; Util -> import ;
__PACKAGE__ -> mk_getset ( qw(list inps outs) ) ;
sub Defs { ( list => {}, inps => {}, outs => {} ) ; }

our $TID = 0 ;

sub _close
  { my $sock = shift ;
    my $tag  = shift ;
    OBB::TT "_close $tag %s", $sock ;
    if ( ref ( $sock ) =~ /Socket/ )
      { my $peer = $sock -> peerhost ;
        my $pprt = $sock -> peerport ;
        my $port = $sock -> sockport ;
        OBB::TT '  peer %s port %s'
          , $peer || 'no_peer' , $port || 'no_port'
            if $peer or $port ;
        logv ( "close $tag %s:%s\n", $peer, $port )
          if $peer and $port ;
      }
    $sock -> close if ref ( $sock ) and $sock -> can ( 'close' ) ;
  }

sub stop
  { my $self = shift ;
    for my $thrd ( values %{ $self -> list } )
#     { $thrd -> stop ; }
      { $self -> Del ( $thrd -> stop ) ; }
  }

sub Add
  { OBB::A_is ( 3, scalar @_ ) ;
    my $self = shift ;
    my $thrd = shift ;
    my $app  = shift ;
    my $out  = $thrd -> out ;
    my $inp  = $thrd -> inp ;
    my $sam  = ( $inp and $inp == $out ) ? 'same' : $out ;
    my $tid  = $thrd -> tid  ( $TID ++ ) ;
    logd ( "Add %s %s\n", ref $thrd, $tid ) ;
    logd ( "  inp [%s]\n", $inp ) if $inp ;
    logd ( "  out [%s]\n", $sam ) if $out ;
    $thrd -> pool ( $self ) ;
    $thrd -> app  ( $app  ) ;
    $self -> list -> { $thrd } = $thrd ;
    $thrd ;
  }

sub Del
  { my $self = shift ;
    my $thrd = shift ;
    logd ( "Del %s %d\n", ref $thrd, $thrd -> tid ) ;
    my $out = $thrd -> out ;
    my $inp = $thrd -> inp ;
    _close $inp, '<-' ;
    _close $out, '->' ;
    $thrd -> gone ( 1 ) ;
    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 $inp and ref ( $inp ) =~ /IO::/ ;
        next if $thrd -> waiting ;
        $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 } ;
        push @res, $thrd if $thrd -> ready_to_do_lines ;
      }
    @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 ;

    OBB::TT 'do_a_loop ...' ;

    for my $h ( $self -> any_writers -> can_write () )
      { my $thrd = $self -> by_out ( $h ) ;
        OBB::TT 'flush 1 %s %s', $thrd, $thrd -> bout ;
        $thrd -> flush ;
      }

    for my $h ( $self -> any_readers -> can_read ( 3 ) )
      { my $thrd = $self -> by_inp ( $h ) ;
        OBB::TT sprintf 'reader %s', $thrd ;
        $self -> Del ( $thrd ) if $thrd -> done ( $self ) ;
      }

    my @readys = $self -> any_readys ;
    OBB::TT 'readys %s', scalar @readys if @readys ;
    for my $thrd ( @readys )
      { OBB::TT 'ready %s %s', $thrd, ref $thrd ;
        $self -> Del ( $thrd ) if $thrd -> done ( $self ) ;
      }

    for my $h ( $self -> any_writers -> can_write () )
      { my $thrd = $self -> by_out ( $h ) ;
        OBB::TT 'flush 2 %s %s', $thrd, $thrd -> bout ;
        $thrd -> flush ;
      }

    @readys = $self -> any_readys ;
    OBB::TT 'readys %s', scalar @readys if @readys ;
    for my $thrd ( @readys )
      { OBB::TT 'ready %s %s', $thrd, ref $thrd ;
        $self -> Del ( $thrd ) if $thrd -> done ( $self ) ;
      }
  }

sub by_tid { $a -> tid <=> $b -> tid } ;

sub Dump
  { my $self = shift ;
    for my $thrd ( sort by_tid values %{ $self -> {list} } )
      { $thrd -> Dump ; }
  }

# Threads
sub STATE
  { my $self = shift ;
    my @list = () ;
    for my $tuple
      ( sort { $a -> [0] cmp $b -> [0] }
          map { $_ -> STATE } sort by_tid values %{ $self -> {list} }
      )
      { my ( $tag, @itms ) = @$tuple ; push @list, @itms ; }
    "threads :\n%s\n", join "\n", map { "-- $_" ; } @list ;
  }

##############################################################
package Dmon::Thread ;
use base 'OBB' ;
use constant COMMAND_DONE => "COMMAND DONE\n" ;
__PACKAGE__ -> mk_getset ( qw(tid inp out app pool ltim gone waitx proxy) ) ;
__PACKAGE__ -> mk_get    ( qw(binp bout) ) ;

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 -> { gone } = 0 ;
    $self -> { waitx } = {} ;
    $self -> { proxy } = 1 ;
    $self ;
  }

sub pipe_to
  { my $self = shift ;
    my $that = shift ;
    $self -> { bout } = $that -> binp ;
    $self -> { out  } = undef ;
    $self ;
  }

sub is_sender   { ref $_[0] eq 'Dmon::Thread::Send' ; }
sub is_receiver { ref $_[0] eq 'Dmon::Thread::Recv' ; }

sub wait4
  { OBB::A_is ( 2, scalar @_ ) ;
    my $self = shift ;
    my $thrd = shift ;
    $self -> waitx -> { $thrd } = $thrd ;
  }
sub waits { values %{ $_[0] -> waitx } ; }
sub waitc { scalar keys %{ $_[0] -> waitx } ; }
sub waiting { my $self = shift ; $self -> is_receiver and $self -> waitc ; }
sub wait_tids { my $self = shift ; map { $_ -> tid } $self -> waits ; }
sub all_gone
  { OBB::A_is ( 1, scalar @_ ) ;
    my $self = shift ;
    ! grep { $_ -> gone == 0 } $self -> waits ;
  }
sub all_gonex
  { OBB::A_is ( 2, scalar @_ ) ;
    my $self = shift ;
    my $gone = shift ;
    $self -> waitc == scalar grep { $_ -> gone == $gone } $self -> waits ;
  }
sub all_gone1 { $_[0] -> all_gonex ( 1 ) ; }
sub all_gone2 { $_[0] -> all_gonex ( 2 ) ; }

sub ready_to_do_lines
  { my $self = shift ;
    my $idx  = $self -> binp -> index ( "\n" ) ;
    my $res  = 0 ;
    if ( $self -> can ( 'timeout' ) and $self -> timeout )
      { $res = 1 ;
        OBB::TT 'ready timed out %s timeout %s', $self, $self -> timeout ;
      }
    elsif ( $self -> waiting and $self -> all_gone1 )
      { $res = 1 ;
        OBB::TT 'ready all_gone1 %s', $self ;
      }
    elsif ( $self -> waiting and $self -> all_gone2 )
      { $res = 1 ;
        OBB::TT 'ready all_gone2 %s', $self ;
      }
    elsif ( $self -> binp == $self -> bout )
      { $res = 0 ; }
    elsif ( $idx != -1 )
      { $res = 1 ;
        OBB::TT 'ready have inp  %s %s', $self, $idx ;
      }
    $res ;
  }

# A 'ready' thread is either "waiting for input" or "waiting for messages"
# A thread is ready-to-run if/when
# -- a timeout occurrs
#    action : for now : treat as if 'ready to read' ;
#    [ the read blocks ; I observer a 6 seconds wait
#    ; followed by a second read (empty), which closed the socket
#      and Del'd the thread
#    ; the application got a (plain) Dmon::Mesg (??)
#    ]
# -- input can be read
#    Action : read input ; progress with 'do_lines' ; set 'done' on EOF
# -- all messages are available to thread (all senders are done/gone) ;
#    [ the thread is either a proxy or a collector of messages
#    ; a proxy just passes on what it receives ;
#    ; a non-proxy has a 'pref' (message prefix), set at thread-creation.
#    ]
#    Action : output ( proxy ? full message : cat pref bodies ) ; set 'done'

# time 100522.999 do_a_loop ...
# time 100526.004 do_a_loop ...
# time 100529.009 do_a_loop ...
# time 100532.013 make to server
# Tue Nov 10 19:09:31 2015 dmon[41041] send REPORT to science-vs33.science.uu.nl
# time 100532.016 to server PORT [22007]
# Tue Nov 10 19:09:31 2015 dmon[41041] Add Dmon::Thread::Send 386
# Tue Nov 10 19:09:31 2015 dmon[41041]   inp [IO::Socket::INET=GLOB(0x2b4b268)]
# Tue Nov 10 19:09:31 2015 dmon[41041]   out [same]
# time 100532.019 make to server done
# time 100532.019 do_a_loop ...
# time 100535.023 do_a_loop ...
# time 100538.028 do_a_loop ...
# time 100541.033 do_a_loop ...
# time 100544.037 ready timed out 386 [[1]]
# time 100544.037 readys [1]
# time 100544.037 ready 386 [Dmon::Thread::Send]
# time 100550.013 read 386 Buff=HASH(0x2d0afc0)
#   [COMMAND REPORT\n{"resp":"ok report from science-vs64.science.uu.nl [131.211.32.73] for science-vs64.science.uu.nl"}\nCOMMAND DONE\n]
# time 100550.014 ready timed out 386 [[1]]
# time 100550.014 readys [1]
# time 100550.014 ready 386 [Dmon::Thread::Send]
# time 100550.022 read 386 Buff=HASH(0x2d0afc0)
#   [empty]
# Tue Nov 10 19:09:49 2015 dmon[41041] Del Dmon::Thread::Send 386
# time 100550.022 _close [IO::Socket::INET=GLOB(0x2b4b268)]
# time 100550.022 _close ; peer [no_peer]
# time 100550.023 _close ; port [48343]
# Tue Nov 10 19:09:49 2015 dmon[41041] close <- no_peer:48343
# time 100550.023 _close ; closed [IO::Socket::INET=GLOB(0x2b4b268)]
# time 100550.023 _close [IO::Socket::INET=GLOB(0x2b4b268)]
# time 100550.023 _close ; peer [no_peer]
# time 100550.023 _close ; port [no_port]
# Can't locate object method "err" via package "Dmon::Mesg" at /usr/sbin/dmon line 4004.
# Tue Nov 10 19:09:49 2015 dmon[41041] daemon exits dirty [syslog'ed]

sub done
  { my $self = shift ;
    my $res  ;
    if ( $self -> can ( 'timeout' ) and $self -> timeout )
      { OBB::TT "timeout ; %s is done", $self ;
        $res = 1 ;
      }
    elsif ( $self -> waiting )
      { if ( $self -> all_gone1 )
          { $self -> bout -> add ( $self -> pref ) unless $self -> proxy ;
            for my $sndr ( $self -> waits )
              { $self -> bout -> add
                  ( $self -> proxy
                  ? $sndr -> rcvd
                  : $sndr -> body
                  ) ;
                $sndr -> gone ( 2 ) ;
                my $rcvd = Util::diag ( $sndr -> rcvd ) ;
                OBB::TT "mesg for %s from %s", $self, $sndr;
                OBB::TT "mesg for %s %s", $self, $rcvd ;
              }
            $self -> bout -> add ( COMMAND_DONE ) unless $self -> proxy ;
            $res = 0 ;
          }
        elsif ( $self -> all_gone2 )
          { $res = 1 ; }
        else
          { $res = 0 ; }
      }
    else
      { my $len = $self -> binp -> sysread ( $self -> inp ) ;
        OBB::TT "read %s %s", $self, $self -> binp ;
        if ( $len )
          { $self -> do_lines ;
            $self -> ltim ( time ) ;
          }
        $res = ! $len ;
      }
    $self -> Xit ( 'bad res for done()' ) unless defined $res ;
    $res ;
  }

# by default, copy to bout
sub do_line
  { my $self = shift ;
    my $line = shift ;
    $line ;
  }

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 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 )
      { print "Dmon::Thread::flush : no out\n" if $self -> Terse ;
        return undef ;
      }
    my $time = time ;

    if ( $tout )
      { eval
          { alarm $tout ;
            $res = syswrite $out, $str ;
            $err = $! unless defined $res ;
            alarm 0 ;
          } ;
        alarm 0 ;
        print "flush : eval[$@]\n" if $@ and $self -> Terse ;
      }
    else
      { $res = syswrite $out, $str ;
        $err = $! unless defined $res ;
      }

    if ( defined $res )
      { $self -> bout -> del ( $res ) ; }
    else
      { my $ival = time - $time ;
        printf
          ( "flush: syswrite returned undef (%s) tout[%s] sec[%s]\n"
          , $err, $tout, $ival
          ) if $self -> Terse ;
      }
    $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' ) ;
      }
    $self ;
  }

sub Dump
  { my $self = shift ;
    if ( $self -> Debug )
      { my $binp = $self -> binp -> get ; $binp =~ s/\n/\\n/g ;
        my $bout = $self -> bout -> get ; $bout =~ s/\n/\\n/g ;
        my $wait = $self -> waiting ;
        printf " self : %s %d\n", $self, $self -> tid ;
        printf "   inp [$self->{inp}]\n" ;
        printf "   out [$self->{out}]\n" ;
        printf "   binp len %2d %s\n", $self -> binp -> length, $self -> binp ;
        printf "   [%s]\n", $binp if $self -> binp -> length ;
        printf "   bout len %2d %s\n", $self -> bout -> length, $self -> bout ;
        printf "   [%s]\n", $bout if $self -> bout -> length ;
        printf "   wait [%s]\n", join ',', $self -> wait_tids if $wait ;
      }
  }

sub diag { my $self = shift ; sprintf "%2d", $self -> tid ; }

# Dmon::Thread
sub STATE
  { my $self = shift ;
    [ "sock $self"
    , join "\n",
        ( sprintf ( "self %s" , $self )
        , sprintf ( "  inp [%s]" , $self-> inp )
        , sprintf ( "  out [%s]" , $self-> out )
        , sprintf ( "  app [%s]" , $self-> app )
        , 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 Dmon::Thread::Service ;
use base 'Dmon::Thread' ;
__PACKAGE__ -> mk_getset ( qw(sock port allowed) ) ;
OBB -> import ; Util -> import ;

sub Init
  { my $self = shift ;
    my %opts = ( port => undef, @_ ) ;
    my $port = $opts { port } ;
    my $sock = new IO::Socket::INET
      ( Listen => 128 , LocalPort => $port, ReuseAddr => 1 ) ;
    $self -> sock ( $sock ) ;
    $self -> port ( $port ) ;
    $self -> mk_allowed ( [], $port ) ;
    $self -> Die ( "Could not create socket for $port ($!)" ) unless $sock ;
    $self -> Dmon::Thread::Init ( $sock, $sock ) ;
  }

sub allow
  { my $self = shift ;
    exists $self -> allowed -> { $_[0] } ;
  }

sub mk_allowed
  { my $self = shift ;
    my $list = shift ;
    my $port = shift ;
    $self -> allowed ( Util::mk_allowed $list, $port ) ;
  }

sub done
  { my $self = shift ;
    my $base = shift ;
    my $sock = $self -> sock -> accept () ;
    my $peer = $sock -> peerhost () ;
    my $port = $sock -> peerport () ;
    if ( $self -> allow ( $peer ) )
      { my $thrd = Dmon::Thread::Recv -> Make ( $sock ) ;
        $self -> app -> del_reject ( $peer ) ;
        $base -> Add ( $thrd, $self -> app ) ;
        Util::logt ( "open  <- $peer:$self->{port} remote $port" )
          if $self -> Terse ;
      }
    else
      { close $sock ;
        $self -> app -> add_reject ( $peer ) ;
        my $mesg = "peer $peer not allowed on port $self->{port}" ;
        Util::logt ( $mesg ) if $self -> Terse ;
      }
    0 ;
  }

# Dmon::Thread::Service
sub STATE
  { my $self = shift ;
    [ "service $self", sprintf "listening on port %s as a %s"
    , $self -> port
    , ref ( $self -> app )
    ] ;
  }

##############################################################
package Dmon::Thread::Recv ;
use base 'Dmon::Thread' ;
__PACKAGE__ -> mk_getset ( qw(pref) ) ;

use constant COMMAND_DONE => Dmon::Thread::COMMAND_DONE ;

sub Init
  { my $self = shift ;
    my $sock = shift ;
    $self -> Dmon::Thread::Init ( $sock, $sock ) ;
    $self -> {pref} = '' ;
    $self ;
  }

# Dmon::Thread::Recv
sub do_line
  { my $self = shift ;
    my $line = shift ;
    my $app = ref ( $self -> app ) ;
    chomp $line ;
    $line =~ /^(\w+\??)\s*/ ;
    my $cmd = $1 || 'empty' ;
    my $arg = $' ; $arg = '' unless defined $arg ;
    my $res = '' ;
    print "COMMAND $cmd\n" if $self -> Terse ;
    if ( $cmd eq 'PING' )
      { my $app = ref $self -> app ;
        my $ver = Dmon -> Version ;
        my $hst = Util -> hostname ;
        $res = "PONG from $app $hst $ver" ;
      }
    elsif ( $cmd eq 'STATE' )
      { my $logf = $self -> app -> conf -> log_file ;
        my $llvl = $self -> app -> conf -> loglvl ;
        my $date = localtime $self -> app -> time0 ;
        $res = ''
          . ( sprintf "-- version  %s\n", Dmon -> Version )
          . ( sprintf "-- logfile  %s\n", $logf )
          . ( sprintf "-- loglevel %s\n", $llvl )
          . ( sprintf "-- started  %s\n", $date )
          . $self -> pool -> STATE
          . "\n"
          . $self -> app  -> STATE
          ;
      }
    elsif ( $cmd eq 'REPORT' )
      { my $val = JSON::PP::decode_json ( $arg || '{}' ) ;
        $res = $self -> app -> do_report ( $val, $self -> inp -> peerhost ) ;
      }
    else
      { $res = $self -> app -> command ( $cmd, $arg, $self ) ; }

    $res = "unknown $app command [$line]" unless defined $res ;
    $self -> STOP if $cmd eq 'STOP' and $res eq Client::STOPPED ;
    if ( $self -> waiting )
      { $self -> pref ( "COMMAND $cmd\n$res" ) unless $self -> proxy ;
        '' ;
      }
    else
      { "COMMAND $cmd\n$res\n" . COMMAND_DONE ; }
  }

sub STOP
  { my $self = shift ;
    $self -> bout -> add ( 'STOPPED' ) ;
    print "stopping ; self flush\n" if $self -> Debug ;
    $self -> flush ;
    print "stopping ; self shutdown\n" if $self -> Debug ;
    $self -> out -> shutdown ( 2 ) ; # done using
    print "stopping ; pool stop\n" if $self -> Debug ;
    $self -> pool -> stop ;
    print "stopping ; base stop done\n" if $self -> Debug ;
    Dmon::Daemon -> ulock ;
    print "stopping ; unlocked\n" if $self -> Debug ;
    $Util::STOP = 'clean' ;
    exit ;
  }

# Dmon::Thread::Recv
sub STATE
  { my $self = shift ;
    my $sock = $self -> inp ;
    [ "serving $self"
    , sprintf "%s is processing a command-session << %s port %s"
        , ref ( $self -> app )
        , $sock -> peerhost, $sock -> sockport
    ] ;
  }

##############################################################
package Dmon::Thread::Send ;
use base 'Dmon::Thread' ;
__PACKAGE__ -> mk_getset ( qw(lines mark tout mbox mesg) ) ;

use constant COMMAND_DONE => Dmon::Thread -> COMMAND_DONE ;

sub Init
  { my $self = shift ;
    my %opts =
      ( hnam => undef
      , port => undef
      , mbox => undef
      , tout => 10
      , @_
      ) ;
    my $hnam = $opts {hnam} ;
    my $port = $opts {port} ;
    my $mbox = $opts {mbox} ;
    my $sock ;
    eval
      { local $SIG{ALRM} = sub { die 'Timed Out'; } ;
        alarm 2 ;
        $sock = IO::Socket::INET -> new
          ( PeerAddr => $opts {hnam}
          , PeerPort => $opts {port}
          , Proto => 'tcp'
          ) ;
        alarm 0 ;
      } ;
    if ( $sock )
      { $self -> Dmon::Thread::Init ( $sock, $sock ) ;
        $self -> mbox ( $opts{mbox} ) ;
        $self -> tout ( $opts{tout} ) ;
        $self -> mark ( time ) ;
        $self -> lines ( [] ) ;
        $self ;
      }
    else
      { undef ; }
  }

sub _mk_mesg
  { my $self  = shift ;
    my $lines = $self -> lines ;
    my $line  = $lines -> [ 0 ] ; chomp $line ;
    my $resp  = 'no proper message received ; TIMEOUT' ;
    if ( $self -> timeout )
      { Dmon::Mesg -> Make ( resp => $resp, lines => $lines ) ; }
    elsif ( $line eq "COMMAND REPORT" )
      { Dmon::Mesg::Report -> Make ( lines => $lines ) ; }
    elsif ( $line eq "COMMAND HIST" )
      { Dmon::Mesg::JSON -> Make ( lines => $lines ) ; }
    elsif ( $line eq "COMMAND CLIENTS" )
      { Dmon::Mesg::Clients -> Make ( lines => $lines ) ; }
    else
      { Dmon::Mesg -> Make ( lines => $lines ) ; }
  }

# Dmon::Thread::Send
sub do_line
  { my $self = shift ;
    my $line = shift ;
    my $lines = $self -> lines ;
    push @$lines, $line ;
    if ( $line eq COMMAND_DONE or $self -> timeout )
      { my $mesg = $self -> _mk_mesg ( lines => $lines ) ;
        my $mbox = $self -> mbox ;
        $self -> mesg ( $mesg ) ;
        push @$mbox, $mesg if defined $mbox ;
      }
    '' ;
  }

sub send
  { my $self = shift ;
    my $mesg = shift ; chomp $mesg ;
    my $idx  = index $mesg, "\n" ;
    $self -> Xit ( "send: newline in mesg ($idx)" ) if $idx >= 0 ;
    $self -> mark ( time ) ;
    $self -> bout -> add ( "$mesg\n" ) ;
    $self -> flush () ;
    $self -> out -> shutdown ( 1 ) ; # done writing
  }

sub rcvd { my $self = shift ; join '', @{ $self -> lines } ; }
sub body
  { my $self = shift ;
    my @lines = @{ $self -> lines } ;
    shift @lines ; pop @lines ;
    join '', @lines ;
  }

sub timeout
  { OBB::A_is 1, scalar @_ ;
    my $self = shift ;
    $self -> tout and time > $self -> mark + $self -> tout ;
  }

# Dmon::Thread::Send
sub STATE
  { my $self = shift ;
    my $sock = $self -> inp ;
    [ "serving $self"
    , sprintf "%s is sending some command-session >> %s port %s"
        , ref ( $self -> app )
        , $sock -> peerhost, $sock -> peerport
    ] ;
  }

##############################################################
package Dmon::Mesg ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(lines) ) ;

sub Init { my $self = shift ; $self -> OBB::Init ( @_ ) ; $self ; }

sub type
  { my $self = shift ;
    my $res  = $self -> lines -> [ 0 ] ; chomp $res ;
    $res || 'no type' ;
  }

sub body { my $self = shift ; join '', @{ $self -> lines } ; }
sub resp { 'stub response' ; }
sub ok   { 1 ; }
sub err  { my $self = shift ; ! $self -> ok ; }

##############################################################
package Dmon::Mesg::JSON ;
use base 'Dmon::Mesg' ;
__PACKAGE__ -> mk_getset ( qw(pvar) ) ;

sub Init
  { my $self = shift ;
    $self -> Dmon::Mesg::Init ( @_ ) ;
    my $line = $self -> lines -> [ 1 ] ;
    $self -> pvar ( Util::as_pvar $line ) ;
    $self ;
  }

sub resp { my $self = shift -> pvar -> {resp} ; }
sub ok   { my $self = shift ; $self -> resp =~ /^ok/ ; }

##############################################################
package Dmon::Mesg::Report ;
use base 'Dmon::Mesg::JSON' ;
sub work_lm { my $self = shift ; $self -> pvar -> { work } ; }

##############################################################
package Dmon::Mesg::Clients ;
use base 'Dmon::Mesg::JSON' ;
sub cdmp    { my $self = shift ; $self -> pvar -> {  cdmp   } ; }
sub events  { my $self = shift ; $self -> pvar -> { events  } ; }
sub event0  { my $self = shift ; $self -> pvar -> { event0  } ; }
sub mesgs   { my $self = shift ; $self -> pvar -> { mesgs   } ; }
sub mesg0   { my $self = shift ; $self -> pvar -> { mesg0   } ; }
sub noalrt  { my $self = shift ; $self -> pvar -> { noalrt  } ; }
sub rejects { my $self = shift ; $self -> pvar -> { rejects } ; }
sub time0   { my $self = shift ; $self -> pvar -> {  time0  } ; }

##############################################################
package Dmon::Mesg::Work ;
use base 'Dmon::Mesg::JSON' ;
sub work { my $self = shift ; $self -> pvar -> { data } ; }
sub lm   { my $self = shift ; $self -> pvar -> { lm   } ; }

##############################################################
package Dmon::Mesg::Hist ;
use base 'Dmon::Mesg::JSON' ;
sub cols { my $self = shift ; $self -> pvar -> { data } { cols } ; }
sub rows { my $self = shift ; $self -> pvar -> { data } { rows } ; }

##############################################################
package Dmon::Daemon ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(conf demn STOP) ) ;
use Fcntl qw(:flock) ;
OBB -> import ; Util -> import ;

our $PROG = Dmon::PROG ;
our $DEMN = 'daemon' ;
our $HOSTNAME = `hostname` ; chomp $HOSTNAME ;

sub Init
  { my $self = shift ;
    my %opts = @_ ;
    my $conf = $self -> conf ( $opts { conf } ) ;
    my $LOGF = $conf -> log_file ;
    my $demn = Proc::Daemon -> new
      ( work_dir     => '.'
      , child_STDOUT => ">>$LOGF"
      , child_STDERR => ">>$LOGF"
      , pid_file     => $conf -> pid_file
      ) ;
    $self -> demn ( $demn ) ;
    $self ;
  }

sub xlock
  { my $self = shift ;
    my $file = $self -> conf -> lck_file ;
    my $cnt  = 0 ;
    my $res  = 0 ;

    unless ( open LOCK, ">$file" )
      { syslog ( "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 # we're the parent
#  -1 # can't run ; other is already running or can't lock
#   0 # we're the daemon ; including opt{i}

sub start_daemon
  { my $self = shift ;
    my $opti = shift ;
    my $pid  = undef ;
    my $demn = $self -> demn ;
    my $msg  ;
    my $cnt  = 0 ;

    while ( $cnt < 3 and $pid = $demn -> Status ( undef ) )
      { $cnt ++ ; sleep 1 ; }

    if ( $pid and $pid != $$ )
      { $msg = "$PROG: some $DEMN is already running ; pid $pid" ;
        $pid = -1 ;
      }
    elsif ( ! $self -> xlock )
      { $msg = "$PROG: can't lock ; some $DEMN is already running" ;
        $pid = -1 ;
      }
    else
      { $self -> ulock ;
        $pid = ( $opti ? 0 : $demn -> Init () ) ;
        $msg = sprintf "$PROG: launched $DEMN 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 => $self -> conf -> port_client
      , Proto => 'tcp'
      ) ;
    if ( $SOCK )
      { printf $SOCK "STOP %s\n", ( $self -> conf -> read_stp || '_' ) ;
        $SOCK -> shutdown ( 1 ) ; # done writing
        my $line = <$SOCK> ;
        $res = 1 if $line and $line eq 'STOPPED' ;
        $SOCK -> shutdown ( 2 ) ; # done using
      }
    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 => $self -> conf -> port_client
      , Proto => 'tcp'
      ) ;
    if ( $SOCK )
      { printf $SOCK "STATE\n" ;
        $SOCK -> shutdown ( 1 ) ; # done writing
        $res = join '', <$SOCK> ;
        $SOCK -> shutdown ( 2 ) ; # done using
      }
    else
      { $res = "can't open sock to daemon" ; }
    $res ;
  }

sub send_reload
  { my $self = shift ;
    my $pid  = shift ;
    ( kill 1, $pid ) ? '' : "can't HUP daemon ($pid)" ;
  }

sub stop_daemon
  { my $self = shift ;
    $self -> demn -> Kill_Daemon ( undef ) unless $self -> send_stop ;
  }

sub status { my $self = shift ; $self -> demn -> Status ( undef ) ; }

sub sss_exit
  { my $self = shift ;
    my $opti = shift ;
    my $ARG  = shift ;
    my @ARGS = @_ ;
    my $ownr = $self -> conf -> own_stp ;
    if ( $ARG and $ARG eq 'start' )
      { my ( $pid, $msg ) = $self -> start_daemon ( $opti ) ;
        if ( $pid )
          { # we are the parent
            syslog ( $msg ) ;
            my $xit = ( $pid < 0 ? 1 : 0 ) ;
            exit $xit unless $opti and $pid > 0 ;
          }
        else
          { # we have a running daemon
            OBB -> Verbosity ( $self -> conf -> loglvl ) ;
            Util::MODE ( 1 ) ;
            Util::rotate ( $self -> conf ) unless $opti ;
            logq ( "$0 start [$$] %s", Dmon -> Version ) ;
            my $sys_lock = $self -> conf -> sys_lock ;
            $self -> xlock ;
            $self -> conf -> make_stp ;
            if ( -d $sys_lock )
              { $self -> conf -> make_sys_lock or syslog
                  ( "can't write sys_lock [%s] ; nevermind", $sys_lock ) ;
              }
            STDOUT -> autoflush ( 1 ) ;
            STDERR -> autoflush ( 1 ) ;
            syslog ( "daemon started" ) ;
          }
      }
    elsif ( $ARG and $ARG eq 'state' )
      { logt ( $self -> send_state ) ; exit 0 ; }

    elsif ( $< and ! defined $ownr )
      { my $nam = getpwuid ( $< ) || $< ;
        logt ( "$PROG: no owner ; $nam can't stat\n" ) ;
        exit 1 ;
      }
    elsif ( $< and $ownr != $< )
      { my $own = getpwuid ( $ownr ) || $ownr ;
        my $nam = getpwuid ( $< ) || $< ;
        logt ( "$PROG: owned by $own ; $nam can't stat\n" ) ;
        exit 1 ;
      }

    elsif ( $ARG and $ARG eq 'stop' )
      { my $pid = $self -> status ;
        my $msg = "$PROG: $DEMN is not running" ;
        my $xit = 0 ;
        if ( $pid )
          { my $cnt = $self -> stop_daemon ;
            $msg = sprintf "$PROG: %s $DEMN on %s ; pid %s"
              , ( $cnt ? 'stopped' : "can't stop" ), $HOSTNAME, $pid ;
            if ( $cnt )
              { $self -> conf -> rm_stp ; $self -> conf -> rm_sys_lock ; }
            $xit = ! $cnt ;
          }
        syslog ( $msg ) ;
        exit ( $xit || 0 ) ;
      }
    elsif ( $ARG and $ARG eq 'reload' )
      { my $pid = $self -> status ;
        my $msg = "$PROG: $DEMN is not running" ;
        if ( $pid ) { $msg = $self -> send_reload ( $pid ) ; }
        logt ( $msg ) ;
        exit 0 ;
      }
    elsif ( $ARG and $ARG eq 'message' )
      { my $serv = $self -> conf -> server ;
        my $port = $self -> conf -> PORT ;
        my $mesg = pop @ARGS ;
        my $item = shift @ARGS ;
        my $levl = shift @ARGS ;
        my $hnam ;
        if ( $item =~ /:/ ) { $hnam = $` ; $item = $' ; }
        $hnam ||= $Util::canonical_hostname ;
        chomp $mesg ;
        my $text = Util::as_text
          ( [ { TIME => time
              , hnam => $hnam
              , item => $item
              , levl => $levl
              , mesg => $mesg
              , type => Dmon::MSG_TAG
              }
            ]
          ) ;
        my $err = "can't talk to server [$serv] [$port]" ;
        my $SOCK = IO::Socket::INET -> new
          ( PeerAddr => $self -> conf -> server
          , PeerPort => $self -> conf -> port_server
          , Proto => 'tcp'
          ) ;
        if ( $SOCK )
          { print $SOCK "EVENTS $text\n" ;
            $SOCK -> shutdown ( 1 ) ; # done writing
            my @lines = <$SOCK> ;
            $SOCK -> shutdown ( 2 ) ; # done using
            print @lines ;
           }
         else
           { print "$err\n" ; exit 1 ; }
         exit 0 ;
      }
    elsif ( $ARG and $ARG =~ /^[gs]etval$/ )
      { my $SOCK = IO::Socket::INET -> new
          ( PeerAddr => 'localhost'
          , PeerPort => $self -> conf -> port_client
          , Proto => 'tcp'
          ) ;
        if ( $SOCK )
          { printf $SOCK "%s @ARGS\n", uc $ARG ;
            $SOCK -> shutdown ( 1 ) ; # done writing
            my @lines = <$SOCK> ;
            $SOCK -> shutdown ( 2 ) ; # done using
            print @lines ;
          }
        else
          { print "can't talk to dmon at localhost\n" ; exit 1 ; }
        exit 0 ;
      }
    elsif ( my $pid = $self -> status )
      { logt ( "$PROG: $DEMN is running ; pid %s\n", $pid ) ;
        exit 0 ;
      }
    else
      { logt ( "$PROG: $DEMN is not running\n" ) ;
        exit 1 ;
      }
    $self ;
  }

##############################################################
package TS ;

use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(file name atrs dbh Err) ) ;
sub Defs { ( file => '', name => 'data', atrs => [] ) ; }

use constant
  { TIME => Dmon::TIME
  , IVAL => Dmon::IVAL
  } ;

sub Reset { my $self = shift ; $self -> Err ( undef ) ; $self ; }

sub nn   { my $x = shift ; not not $x ; }
sub null { defined $_[0] ? $_[0] : 'NaN' ; }
sub tnam { my $x = pop ; $x =~ s/[^\w]/_/g ; $x }

sub connect
  { my $self = shift -> Reset ;
    my $file = $self -> file ;
    my $res  = 0 ;
    unless ( $file )
      { $self -> Err ( 'TS: no file' ) ; }
    else
      { my $dbh = DBI -> connect
          ( "dbi:SQLite:dbname=$file", "", ""
          , { AutoCommit => 1
            , RaiseError => 0
            , sqlite_see_if_its_a_number => 1
            }
          ) ;
        $res = nn $self -> dbh ( $dbh ) ;
      }
    $res ;
  }

sub disconnect
  { my $self = shift -> Reset ;
    my $dbh  = $self -> dbh ;
    my $res  = 0 ;
    unless ( $dbh )
      { $self -> Err ( 'not connected' ) ; }
    elsif ( $dbh -> disconnect )
      { $self -> dbh ( undef ) ; $res = 1 ; }
    else
      { $self -> Err ( "can't disconnect" ) ; }
    $res ;
  }

sub _table_info
  { my $self = shift ;
    my $dbh  = $self -> dbh ;
    my $res  = undef ;
    return $res unless $dbh ;
    my $sth = $dbh -> table_info ( undef, undef, '%', 'TABLE' ) ;
    if ( $sth )
      { $res = $sth -> fetchall_arrayref ; }
    else
      { $self -> Err ( "_table_info : can't" ) ; }
    $res ;
  }

sub _column_info
  { my $self = shift ;
    my $name = shift ;
    my $dbh  = $self -> dbh  ;
    my $res  = undef ;
    return $res unless $dbh and $name ;
    my $sth = $dbh -> column_info ( undef, undef, $name, '%' ) ;
    if ( $sth )
      { $res = $sth -> fetchall_arrayref ; }
    else
      { $self -> Err ( "_column_info : can't" ) ; }
    $res ;
  }

sub _tabs
  { OBB::A_is 1, scalar @_ ;
    my $self = shift -> Reset ;
    my $info = $self -> _table_info ;
    my $res  = undef ;
    if ( $info )
      { $res = [ sort map { $_ -> [2] ; } @$info ] ; }
    else
      { $self -> Err ( "_table_info : can't" ) ; }
    $res ;
  }

sub _cols
  { OBB::A_is 2, scalar @_ ;
    my $self = shift -> Reset ;
    my $name = shift ;
    my $info = $self -> _column_info ( $name ) ;
    my $res  = undef ;
    if ( $info )
      { $res = [ sort map { $_ -> [3] ; } @$info ] ; }
    else
      { $self -> Err ( "_column_info : can't" ) ; }
    $res ;
  }

sub user_cols
  { OBB::A_is 2, scalar @_ ;
    my $self = shift ;
    my $res  = [ grep $_ ne TIME, @{ $self -> _cols ( @_ ) } ] ;
    wantarray ? @$res : $res ;
  }

sub has_tab
  { OBB::A_is 2, scalar @_ ;
    my $self = shift ;
    my $name = shift ;
    scalar grep $_ eq $name, @{ $self -> _tabs } ;
  }

sub add_tab_sql
  { OBB::A_in 2, 3, scalar @_ ;
    my $self = shift ;
    my $name = shift ;
    my $cols = shift || [] ;
    sprintf "CREATE TABLE %s ( %s integer primary key %s )"
      , $name, TIME
      , ( @$cols ? map { ", $_" ; } @$cols : '' ) ;
  }

sub add_tab
  { OBB::A_is 2, scalar @_ ;
    my $self = shift ;
    my $name = shift ;
    my $res = 1 ;
    unless ( $self -> has_tab ( $name ) )
      { $res = $self -> dbh -> do ( $self -> add_tab_sql ( $name ) ) ;
        printf "added table $name\n" if $self -> Verbose ;
      }
    elsif ( $self -> Verbose )
      { printf "already have table $name\n" ; }
    $res ;
  }

sub del_tab
  { OBB::A_is 2, scalar @_ ;
    my $self = shift ;
    my $name = shift ;
    printf "%s table $name\n",
      $self -> has_tab ( $name ) ? 'drop' : '[warn] no' ;
    nn $self -> dbh -> do ( "DROP TABLE IF EXISTS $name" ) ;
  }

sub has_col
  { OBB::A_is 3, scalar @_ ;
    my $self = shift ;
    my $name = shift ;
    my $col  = shift ;
    scalar grep $_ eq $col, @{ $self -> _cols ( $name ) } ;
  }

sub add_col
  { OBB::A_in 4, 5, scalar @_ ;
    my $self = shift ;
    my $name = shift ;
    my $col  = shift ;
    my $typ  = shift ;
    my $xtra = shift || '' ;
    my $res  = 1 ;
    unless ( $self -> has_col ( $name, $col ) )
      { $res = $self -> dbh -> do
          ( "ALTER TABLE $name ADD COLUMN $col $typ $xtra" ) ;
        OBB::TT ( "added field $name.$col:$typ %s", $xtra ) ;
      }
    elsif ( $self -> Verbose )
      { OBB::TT ( "already have $name.$col" ) ; }
    $res ;
  }

sub _upd_cols_sql
  { OBB::A_is 3, scalar @_ ;
    my $name = shift ;
    my $olds = shift ; # list of old names
    my $news = shift ; # list of new names
    my $oldnams = join ', ', TIME, @$olds ;
    my $newnams = join ', ', TIME, @$news ;
    my $newtyps = join ', ',
        map
          { ( $_ eq TIME
            ? 'TIME integer primary key'
            : ( $_ eq IVAL
              ? 'IVAL real NOT NULL DEFAULT 1'
              : "$_ real"
              )
            ) ;
          } ( TIME, @$news ) ;
    my $tnam    = "tmp_$name" ;
    my $SQL = <<SQL ;
BEGIN TRANSACTION;
CREATE TEMPORARY TABLE tmp_$name ( $newtyps ) ;
INSERT INTO $tnam ( $newnams ) SELECT $oldnams FROM $name ;
DROP TABLE $name ;
CREATE TABLE $name ( $newtyps ) ;
INSERT INTO $name ( $newnams ) SELECT $newnams FROM $tnam ;
DROP TABLE $tnam ;
COMMIT;
SQL
  }

sub move_col
  { OBB::A_is 4, scalar @_ ;
    my $self = shift ;
    my $name = shift ;
    my $old  = shift ;
    my $new  = shift ;
    my $res  = 0 ;
    unless ( $self -> has_col ( $name, $old ) )
      { printf "[err] don't have $name.$old\n" ; }
    elsif ( $old eq $new )
      { printf "[warn] old [$old] == new [$new]\n" ; $res = 1 ; }
    elsif ( $old eq TIME )
      { printf "[warn] won't move TIME\n" ; }
    elsif ( $self -> has_col ( $name, $new ) )
      { printf "[err] already have $name.$new\n" ; }
    else
      { printf "move $name.$old $name.$new\n" ;
        my $olds = [ sort $self -> user_cols ( $name ) ] ;
        my $news = [ map { $_ eq $old ? $new : $_ } @$olds ] ;
        my $SQL = _upd_cols_sql $name, $olds, $news ;
        print $SQL if $self -> Debug ;
        $res = nn $self -> dbh -> do ( $_ ) for split "\n", $SQL ;
      }
    $res ;
  }

sub drop_cols
  { OBB::A_ge 3, scalar @_ ;
    my $self = shift ;
    my $name = shift ;
    my @cols = @_ ;
    my %keep ; $keep { $_ } ++ for $self -> user_cols ( $name ) ;
    my $drps = 0 ;
    my $res  = 0 ;
    for my $col ( @cols )
      { if ( $col eq TIME )
          { printf "[err] won't drop $name.$col\n" ; }
        elsif ( $keep { $col } )
          { printf "drop $name.$col\n" ; $drps ++ ; delete $keep { $col } ; }
        else
          { printf "[err] no $name.$col\n" ; }
      }
    my $keeps = scalar keys %keep ;
    unless ( $keeps )
      { $res = $self -> del_tab ( $name ) ; }
    elsif ( $drps )
      { my $keep = [ sort keys %keep ] ;
        my $SQL = _upd_cols_sql $name, $keep, $keep ;
        print $SQL if $self -> Debug ;
        $res = nn $self -> dbh -> do ( $_ ) for split "\n", $SQL ;
      }
    else # no change
      { print "no change\n" ; $res = 1 ; }
    $res ;
  }

sub has_row
  { OBB::A_is 3, scalar @_ ;
    my $self = shift ;
    my $name = shift ;
    my $time = shift ;
    $self -> count ( $name, where => "TIME = $time" ) ? 1 : 0 ;
  }

sub _flat ;
sub _flat
  { my @res = () ;
    for my $itm ( @_ )
      { push @res, ( ( ref $itm eq 'ARRAY' ) ? _flat @$itm : $itm )
          if defined $itm ;
      }
    @res ;
  }

our %KWDS ;
our @KWDS = qw(where group_by having order_by limit) ;
@KWDS { @KWDS } = map { my $x = $_ ; $x =~ s/_/ / ; uc $x ; } @KWDS ;

sub _mk_sql_select
  { OBB::A_ge 1, scalar @_ ;
    my $name = shift ;
    my %opts = ( from => $name , @_ ) ;
    my $cols = join ( ',', _flat $opts{cols} ) || "$name.*" ;
    sprintf "SELECT %s FROM %s %s %s %s %s %s"
      , $cols, $opts { from }
      , map { $opts{$_} ? "$KWDS{$_} $opts{$_}" : '' ; } @KWDS ;
  }

sub _mk_sql_delete
  { OBB::A_ge 1, scalar @_ ;
    my $name = shift ;
    my %opts = ( from => $name , @_ ) ;
    sprintf "DELETE FROM %s %s"
      , $opts { from }
      , map { $opts{$_} ? "$KWDS{$_} $opts{$_}" : '' ; } qw(where) ;
  }

sub _select_sth
  { OBB::A_ge 2, scalar @_ ;
    my $self = shift -> Reset ;
    my $name = shift ;
    my %opts = @_ ;
    my $dbh  = $self -> dbh ;
    unless ( $self -> has_tab ( $name ) )
      { $self -> Err ( "no table $name" ) ; return undef ; }
    my $SQL  = _mk_sql_select ( $name, order_by => TIME, %opts ) ;
    printf "${SQL}\n" if $self -> Debug ;
    my $sth = $dbh -> prepare ( $SQL ) ;
    $self -> Err ( "can't prepare $SQL" ) unless $sth ;
    $sth ;
  }

sub _select
  { OBB::A_ge 4, scalar @_ ;
    my $self = shift ;
    my $one  = shift ;
    my $tups = shift ;
    my $sth  = $self -> _select_sth ( @_ ) ;
    my $res  = [] ;
    if ( $sth )
      { $sth -> execute () ;
        if ( $tups eq 'tups' )
          { while ( my $row = $sth -> fetchrow_arrayref )
              { push @$res, [ @$row ] }
          }
        else
          { while ( my $hsh = $sth -> fetchrow_hashref )
              { push @$res, { %$hsh } }
          }
      }
    $one ? $res -> [ 0 ] : $res ;
  }

sub select
  { OBB::A_ge 2, scalar @_ ; shift -> _select ( 0, 'tups', @_ ) ; }
sub select_hash
  { OBB::A_ge 2, scalar @_ ; shift -> _select ( 0, 'hash', @_ ) ; }
sub select1
  { OBB::A_ge 2, scalar @_ ; shift -> _select ( 1, 'tups', @_ ) ; }
sub select1_hash
  { OBB::A_ge 2, scalar @_ ; shift -> _select ( 1, 'hash', @_ ) ; }

sub delete
  { OBB::A_ge 2, scalar @_ ;
    my $self = shift ;
    my $name = shift ;
    my %opts = @_ ;
    my $dbh  = $self -> dbh ;
    unless ( $self -> has_tab ( $name ) )
      { printf "no table $name\n" ; return [] ; }
    my $SQL  = _mk_sql_delete ( $name, %opts ) ;
    printf "${SQL}\n" if $self -> Debug ;
    my $res = $dbh -> do ( $SQL ) ;
    # or Carp::confess "can't do $SQL" ;
    $res ;
  }

sub count
  { OBB::A_ge 2, scalar @_ ;
    my $self = shift ;
    my $name = shift ;
    my %opts = @_ ;
    my $tups = $self -> select ( $name, %opts, cols => 'count(*) as count' ) ;
    $tups -> [ 0 ] [ 0 ] ;
  }

sub aggregates
  { OBB::A_ge 4, scalar @_ ;
    my $self = shift ;
    my $name = shift ;
    my $col  = shift ;
    my @typs = @_ ;
    my $tups = $self -> select
      ( $name , cols => [ map "$_($col) as $_", @typs ] ) ;
    @typs > 1 ? @{ $tups -> [ 0 ] } : $tups -> [ 0 ] [ 0 ] ;
  }

sub min { aggregates ( @_, 'MIN' ) ; }
sub max { aggregates ( @_, 'MAX' ) ; }
sub avg { aggregates ( @_, 'AVG' ) ; }
sub mma { aggregates ( @_, qw(MIN MAX AVG) ) ; }

sub check
  { my $self = shift ;
    my $res  = 1 ;
    for my $name ( sort @{ $self -> _tabs } )
      { unless ( $self -> has_col ( $name, TIME ) )
          { printf "[err] no column TIME in $name" ; $res = 0 ; }
      }
    $res ;
  }

sub save_hash
  { OBB::A_in 3, 5, scalar @_ ;
    my $self = shift ;
    my $name = shift ;
    my $hash = shift ;
    my $time = shift || time ;
    my $aadd = shift || 0 ;
    my @cols = () ;
    my @vals = () ;
    my $SQL  ;

    for my $atr ( sort keys %$hash )
      { my $val = $hash -> { $atr } ;
        if ( $self -> has_col ( $name, $atr ) )
          { push @cols, $atr ; push @vals, $val ; }
        else
          { printf "[warn] no $name.$atr ignore [%s]\n", ( $val || '' ) ; }
      }

    unless ( @cols ) { printf "[err] no valid cols\n" ; return 0 ; }

    if ( ! $aadd and $self -> has_row ( $name, $time ) )
      { my $ulst = join ',', map "$_ = ?", @cols ;
        $SQL = sprintf "UPDATE %s SET %s WHERE %s = %s"
          , $name, $ulst, TIME, $time ;
      }
    else
      { my $clst = join ',', @cols ;
        my $vlst = join ',', map '?', @cols ;
        $SQL = sprintf "INSERT INTO %s ( %s, %s ) VALUES ( %s, %s )"
          , $name, TIME, $clst, $time, $vlst ;
      }
    printf "${SQL} ; [%s]\n", join ',', map { null $_ ; } @vals
      if $self -> Debug ;
    $SQL .= "\n" ;
    my $sth = $self -> dbh -> prepare ( $SQL ) or
      Carp::confess "can't prep $SQL" ;
    $sth -> execute ( @vals ) ? $time : 0 ;
  }

sub insert_tups
  { OBB::A_is 4, scalar @_ ;
    my $self = shift ;
    my $name = shift ;
    my $nams = shift ;
    my $tups = shift ;
    my @cols = () ;
    my @idxs = () ;
    my $res  = 1 ;

    unless ( grep $_ eq TIME, @$nams )
      { printf "[err] no TIME in tuples?\n" ; return 0 ; }

    my $idx  = 0 ;
    for my $nam ( @$nams )
      { if ( $self -> has_col ( $name, $nam ) )
          { push @cols, $nam ; push @idxs, $idx ; }
        else
          { print "[warn] no $name.$nam ; ignore\n" ; }
        $idx ++ ;
      }

    unless ( @cols ) { printf "[err] no valid cols\n" ; return 0 ; }

    my $clst = join ',', @cols ;
    my $vlst = join ',', map '?', @cols ;
    my $SQL = sprintf "INSERT INTO %s ( %s ) VALUES ( %s )"
      , $name, $clst, $vlst ;

    printf "${SQL} ; \@tup[%s]\n", join ',', map { $_ ; } @idxs
      if $self -> Debug ;
    $SQL .= "\n" ;
    my $dbh = $self -> dbh ;
    my $sth ;
    my $cnt = 0 ;
    $dbh -> begin_work or die $dbh -> errstr ;
    $sth = $dbh -> prepare ( $SQL ) or Carp::confess "can't prep $SQL" ;
    for my $tup ( @$tups )
      { my $r = ( $sth -> execute ( @$tup [ @idxs ] ) ? $res : 0 ) ;
        die "bad tup [@$tup]\n" unless $r ;
        $res &= $r ;
        $cnt ++ ;
      }
    $dbh -> commit or die $dbh -> errstr ;
    ( $res ? scalar @$tups : 0 ) ;
  }

sub zap
  { OBB::A_is ( 4, scalar @_ ) ;
    my $self = shift ;
    my $tnam = shift ;
    my $IVAL = shift ;
    my $keep = shift ;
    my $res ;

    OBB -> Xit ( "no table [$tnam]" ) unless $self -> has_tab ( $tnam ) ;

    my $tmax = time - $keep ; $tmax -= $tmax % $IVAL ;
    my $date = Util::ddate $tmax ;
    my $grp  = "TIME / $IVAL" ;
    my @cols = grep $_ ne 'IVAL', $self -> user_cols ( $tnam ) ;
    my $colt = 'MIN ( TIME ) as TIMEx' ;
    my $coli = 'SUM ( IVAL ) as IVALx' ;
    my $cnt  = 0 ;
    OBB::TT "zap tnam %s IVAL %s tmax %s\n  %s"
      , $tnam, $IVAL, $date, join ',', @cols ;
    my $rows = $self -> select
      ( $tnam
      , cols =>
          [ $colt
          , $coli
          , map { "SUM ( IVAL * $_ ) / SUM ( IVAL ) as $_" } @cols
          ]
      , where => "TIME < $tmax"
      , group_by => $grp
      , having   => '( COUNT(*) > 1 AND SUM ( IVAL ) > 0 )'
      ) ;
    my $rcnt = scalar @$rows ;
    Util::logt ( "zap %s %s chunks %s", $IVAL, $date, $rcnt ) ;
    for my $row ( @$rows )
      { my $hash ; @{$hash} { qw(TIME IVAL), @cols } = @$row ;
        my $TIME = $hash -> { TIME } ;
        $TIME = $TIME - $TIME % $IVAL ;
        delete $hash -> { TIME } ;
        $self -> dbh -> begin_work ;
        my $del = $self -> delete
          ( $tnam, where => "$TIME <= TIME and TIME < $TIME + $IVAL" ) ;
        $self -> save_hash ( $tnam, $hash, $TIME ) ;
        $self -> dbh -> commit ;
        my $dat = Util::ddate $TIME ;
        my $ivl = $hash -> { IVAL } ;
        Util::logt ( "zap $del %s ival $ivl", $dat ) ;
        $cnt += $del ;
      }
    $self -> dbh -> do ( 'VACUUM' ) ;
    OBB::TT "zap $IVAL $date done" ;
    my $err  = $self -> Err ;

    $res =
      ( $err
      ? "no good: $err"
      : "ok zapped $cnt rows in $rcnt chunks"
      ) ;
    Util::logt ( 'zap %s', $res ) ;
    $res ;
  }

sub zap_old
  { OBB::A_is ( 3, scalar @_ ) ;
    my $self = shift ;
    my $tnam = shift ;
    my $keep = shift ;

    OBB -> Xit ( "no table [$tnam]" ) unless $self -> has_tab ( $tnam ) ;

    my $tmax = time - $keep ;
    my $date = Util::ddate $tmax ;
    my $cnt  = $self -> count ( $tnam ) ;
    OBB::TT "zap_old $date ; have $cnt" ;
    $self -> dbh -> begin_work ;
    my $del = $self -> delete ( $tnam, where => "TIME < $tmax" ) ;
    $del = 0 if $del and $del eq '0E0' ;
    $self -> dbh -> commit ;
    OBB::TT "zap_old $date done ; del $del" ;
    my $err = $self -> Err ;
    my $res =
      ( $err
      ? "no good zap_old : $err"
      : "ok zapped $del old rows in $tnam"
      ) ;
    Util::logt ( 'zap_old %s %s', $date, $res ) ;
    $res ;
  }

###################################################################
package Dmon::Rejects ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(hash) ) ;
sub Defs { ( hash => {} ) ; }

sub list
  { my $self = shift ;
    my $hash = $self -> hash ;
    sort { $a -> peer cmp $b -> peer } values %$hash ;
  }

sub add
  { my $self = shift ;
    my $peer = shift ;
    my $hash = $self -> hash ;
    unless ( exists $hash -> { $peer } )
      { $hash -> { $peer } = Dmon::Reject -> Make
          ( peer => $peer
          , cnt  => 0
          , frst => time
          , last => time
          ) ;
      }
    $hash -> { $peer } -> incr ;
  }

sub del
  { my $self = shift ;
    my $peer = shift ;
    delete $self -> {hash} { $peer } ;
  }

# $hash == CLIENTS -> rejects
sub add_json
  { my $self = shift ;
    my $json = shift ;
    for my $peer ( keys %$json )
      { my $data = $json -> { $peer } ;
        $self -> {hash} { $peer } = Dmon::Reject -> Make ( %$data ) ;
      }
  }

###################################################################
package Dmon::Reject ;
use base 'OBB' ;
__PACKAGE__ -> mk_getset ( qw(peer cnt frst last) ) ;

sub incr
  { my $self = shift ;
    $self -> cnt  ( $self -> cnt + 1 ) ;
    $self -> last ( time ) ;
  }

sub diag { my $self = shift ; Util::diag $self -> peer ; }

1 ; 
package main ;
#! /usr/bin/perl

use strict ;
use warnings ;

Dmon -> import ; OBB -> import ; Util -> import ;

my @COMMAND_LINE = ( $0, @ARGV ) ;
my @COMMAND_ARGS = qw(stop start reload state message getval setval) ;

my $PAT_ARGS = join '|', @COMMAND_ARGS ;

my $prog = substr $0, rindex ( $0, '/' ) + 1 ;
my $Usage = <<USAGE ;
Usage: $prog [OPTIONS] [COMMANDS]
OPTIONS  : [-s] [-q] [-v] [-d] [-h] [-i] [-t] [-p port] [-c file]
COMMANDS : $PAT_ARGS
option s : be silent
option q : be quiet ; only errors
option v : be verbose ; show all actions
option d : show debug info ; internals
option T : trace ; show all debug info
option h : show help ; exit
option t : test config and work ; exit
option i : interactive ; don't fork the daemon
option p : use port \$port ; default : config ;
option c : use config <file> ; default [@{[join ',', Conf::FILES]}]
COMMAND message [host:]item [level] string :
  store a message about host:item ;
  default host  : canonical hostname of localhost
  default level : dmon default level
COMMAND getval [host:]item number :
  get the value of host:item ;
  default host  : canonical hostname of localhost
COMMAND getval :
  list the values of all host:item's
COMMAND setval [host:]item number :
  set the value of host:item ;
  default host  : canonical hostname of localhost
  item.probe must be 'hist'
USAGE
sub Usage { die "$_[0]$Usage" ; }
sub Error { die "[error] $prog: $_[0]\n" ; }
sub Warn  { warn "[warn] $prog: $_[0]\n" ; }

# 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 %opt = () ; Usage '' unless GetOptions
  ( \%opt, qw(s q v d T h t i c=s p=i version test) ) ;
if ( @ARGV )
  { if ( $ARGV[0] eq 'message' )
      { Usage "Arg count\n" unless 3 <= @ARGV and @ARGV <= 4 ; }
    elsif ( $ARGV[0] eq 'getval' )
      { Usage "Arg count\n" unless 1 <= @ARGV and @ARGV <= 2 ; }
    elsif ( $ARGV[0] eq 'setval' )
      { Usage "Arg count\n" unless @ARGV == 3 ; }
    elsif ( @ARGV > 1 )
      { Usage "Arg count\n" ; }
  }
Usage "Bad argument ($ARGV[0]) \n" if @ARGV and $ARGV[0] !~ /^$PAT_ARGS$/ ;

$opt{d} ||= $opt{T} ;
$opt{v} ||= $opt{d} ;
OBB -> Verbosity ( 'Silent'  ) if $opt{s} ;
OBB -> Verbosity ( 'Quiet'   ) if $opt{q} ;
OBB -> Verbosity ( 'Verbose' ) if $opt{v} ;
OBB -> Verbosity ( 'Debug'   ) if $opt{d} ;
OBB -> Verbosity ( 'Trace'   ) if $opt{T} ;
if ( $opt{h} ) { print $Usage ; exit ; }
if ( $opt{version} ) { print Dmon -> Version, "\n" ; exit ; }

my $ARG = shift || '' ;

# Probe::Util::secs_expire ( '201806280000' ) ; exit ;
# printf "%s\n", Util::ddate time ; exit ;

my $conf = Conf -> Make ( file => $opt{c} ) ;

$conf -> PORT ( 23007 ) if $opt{test} ;
$conf -> PORT ( $opt{p} ) if $opt{p} ;
$conf -> Dmp ( 'config' ) if $opt{v} ;
Util -> INITx ( conf => $conf ) ;

my $HUP  = 0 ;
my $USR1 = 0 ;
$SIG { INT } = sub { OBB::logx ( 'SIG INT' ) ; exit ; } ;
$SIG { HUP } = sub { OBB::logx ( 'SIG HUP' ) ; $HUP = 1 ; } ;
$SIG { USR1 } = sub { OBB::logx ( 'SIG USR1' ) ; $USR1 = time ; } ;

my $daemon  = Dmon::Daemon -> Make ( conf => $conf )
  -> sss_exit ( $opt{i}, $ARG, @ARGV ) unless $opt{t} ;
my $threads = Threads -> Make unless $opt{t} ;
my $hnam    = $Util::canonical_hostname ;

my $SERVER  = Server -> Make ( conf => $conf, threads => $threads )
  if $conf -> server eq $hnam ;
my $CLIENT  = Client -> Make ( conf => $conf, threads => $threads ) ;
my $itms    = $CLIENT -> work -> hosts -> { $hnam } ;
my $server  = $CLIENT -> server ;
my $stamp   = $CLIENT -> work -> stamp ;
my $srv_hnm = $server -> hnam ;
my $snd_rps = 1 ;

if ( $SERVER )
  { $SERVER -> CLIENT ( $CLIENT ) ;
    $CLIENT -> SERVER ( $SERVER ) ;
  }

sub time_x ($$)
  { my $incr = shift ;
    my $rand = shift ;
    int ( time + $incr - $rand / 2 + rand $rand ) ;
  }

sub reload
  { logq ( 'reload' ) ;
    my $newc ;
    my $eval = eval { $newc = Conf -> Make ( file => $conf -> file ) ; 1 ; } ;
    my $res = 1 ;
    unless ( defined $eval )
      { logq ( "reload bad [$@]" ) ; $res = 0 ; }
    else
      { $conf = $newc ;
        $conf -> PORT ( 23007 ) if $opt{test} ;
        OBB -> Verbosity ( $conf -> loglvl ) ;
        $threads -> stop ;
        $SERVER -> Init ( conf => $conf, threads => $threads ) if $SERVER ;
        $CLIENT -> Init ( conf => $conf, threads => $threads ) ;
        $snd_rps = 1 ;
        logq ( 'reload ok' ) ;
      }
    $res ;
  }

sub mk_next_stat { map { ( $_ => time ) ; } $CLIENT -> state -> hnams ; }

if ( $opt{v} )
  { printf "hostname [%s]\n", $hnam ;
    printf "logdir   [%s]\n", $conf -> logdir ;
    printf "rundir   [%s]\n", $conf -> rundir ;
    printf "upgrdir  [%s]\n", $conf -> upgrdir ;
    printf "rotate   [%s]\n", scalar localtime time + $conf -> rot_ivl ;
    printf "server   [%s]\n", $server ? $srv_hnm : 'no server' ;
    printf "distrib  [%s]\n", $Util::DISTRIB ;
    printf "stamp    [%s]\n", scalar localtime $stamp ;
    printf "levels   [%s]\n", $CLIENT -> show_levels ;
    printf "PATH     [%s]\n", $ENV { PATH } ;
    $CLIENT -> work -> Dmp ( 'client work' ) ;
    if ( $SERVER )
      { printf "ServHist [%s]\n", $SERVER -> CLIENT -> hist ;
        printf "pmaker   [%s]\n", $SERVER -> work -> pmaker ;
        $SERVER -> work -> Dmp ( 'server work' ) ;
      }
  }

printf "my items :\n  [ %s\n  ]\n", join "\n  , ", sort keys %$itms
  if $opt{v} ;

exit if $opt{t} ;

$| = 1 ;

my %next_stat = mk_next_stat ;
my $next_work = time + $conf -> ival_check_work ;
my $next_rotl = time + $conf -> rot_ivl ;
my $next_zaps = time + 30 ;
my $from_server = [] ;
my $work_lm     = undef ;

$CLIENT -> send_server_reboot ( $hnam, $from_server ) ;

while ( 1 )
  { for my $hnam ( $CLIENT -> state -> hnams )
      { if ( time >= $next_stat { $hnam } or $CLIENT -> vals -> cnt ( $hnam ) )
          { my ( $upds, $events ) = $CLIENT -> mk_update ( $hnam ) ;
            if ( $upds )
              { my $hash = $CLIENT -> state -> hist_hash ( $hnam ) ;
                logt ( 'save to history' ) ;
                OBB::Dmp ( $hash, 'hist hash' ) if OBB -> Terse ;
                $CLIENT -> save_hist ( $hnam, $hash ) ;
                OBB::TT 'event %s', $_ for @$events ;
              }
            if ( @$events )
              { logt ( "send events (%s) to $srv_hnm", scalar @$events ) ;
                my $text = Util::as_text ( OBB -> Unbless ( $events ) ) ;
                my $sender = $CLIENT -> send_server
                  ( "EVENTS $text", $from_server ) ;
                if ( $sender )
                  { $CLIENT -> next_send ( time ) ; }
                else
                  { logq ( "can't connect to server $srv_hnm" ) ; }
              }
            $next_stat { $hnam } = time_x $conf -> ival_make_state, 1 ;
          }
      }
    
    if ( time > $next_zaps )
      { my @hnams = $CLIENT -> state -> hnams ;
        logt ( 'do ZAP [%s]', join ',', @hnams ) ;
        $CLIENT -> zap_hist ( $_ ) for @hnams ;
        if ( $SERVER )
          { $CLIENT -> zap_old ( Dmon::T_EVNTS, $conf -> ival_keep_events ) ;
            $CLIENT -> zap_old ( Dmon::T_MESGS, $conf -> ival_keep_mesgs )
          }
        $next_zaps = time_x $conf -> zap_ivl, 10 ;
      }

    if ( time >= $CLIENT -> next_send )
      { OBB::TT 'make to server' ;
        logt ( "send REPORT to $srv_hnm" ) ;
        my $text = 'REPORT ' . $CLIENT -> state -> as_text ;
        my $send_server = $CLIENT -> send_server ( $text, $from_server ) ;
        OBB::TT 'make to server done' ;
        my $next = time_x $conf -> ival_send_report, 10 ;
        unless ( $send_server )
          { logq ( "can't connect to server $srv_hnm" ) ;
            $next = time_x 60, 10 ;
          }
        $CLIENT -> next_send ( $next ) ;
        $work_lm = undef ;
      }

    $threads -> do_a_loop ;

    while ( @$from_server )
      { my $recv = shift @$from_server ;
        logq ( "warn [%s]\n", $recv -> resp ) if $recv -> err ;
        logt
          ( $recv -> err
          ? $recv -> resp
          : "received message type [%s]\n", $recv -> type
          ) ;
        logv ( "resp [%s]\n", $recv -> resp ) ;
        logd ( "received:\n%send", $recv -> body ) ;
        if ( ! $recv -> err and $recv -> type eq 'COMMAND REPORT' )
          { $work_lm = $recv -> work_lm ; }
      }

     if ( time > $next_work )
       { my $HUP1 = $CLIENT -> new_work ( $work_lm ) ;
         my $HUP2 = ( $SERVER and $SERVER -> new_work ) ;
         $HUP ||= ( $HUP1 || $HUP2 ) ;
         $next_work = time_x $conf -> ival_check_work, 8 ;
       }
    
     if ( time > $next_rotl )
       { Util::rotate ( $conf ) ; $next_rotl = time + $conf -> rot_ivl ; }
    
    if ( $SERVER and $snd_rps and ! $opt{test} )
      { logt ( "send ALLSEND to $srv_hnm" ) ;
        my $send_server = $CLIENT -> send_server ( 'ALLSEND', $from_server ) ;
        logq ( "can't connect to server $srv_hnm" ) unless $send_server ;
        $snd_rps = 0 ;
      }
  
     if ( $HUP ) { $HUP = 0 ; %next_stat = mk_next_stat if reload ; }
     
     my $rexec = $CLIENT -> rexec || $USR1 ;
     if ( $rexec and time > $rexec )
       { $Util::EXEC = 1 ;
         $Util::STOP = 'rexec' ;
         Dmon::Daemon -> ulock ;
         exit ;
       }
  }

END
  { if ( Util::MODE )
      { syslog
          ( $Util::STOP eq 'dirty'
          ? 'daemon exits dirty'
          : "daemon stopped ($Util::STOP)"
          ) ;
        $conf -> rm_sys_lock ;
      }
    exec @COMMAND_LINE if $Util::EXEC ;
  }