#! /usr/bin/perl

# ---------------------------------------------------------------------
# Copyright (c) 2011-2013 Henk P. Penning.
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are
# met:
#
#   1. Redistributions of source code must retain the above copyright
#   notice,
#      this list of conditions and the following disclaimer.
#
#   2. Redistributions in binary form must reproduce the above copyright
#      notice, this list of conditions and the following disclaimer in the
#      documentation and/or other materials provided with the
#      distribution.
#
# THIS SOFTWARE IS PROVIDED BY Henk P. Penning, ``AS # IS'' AND ANY
# EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
# PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL Henk P.  Penning OR
# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# The views and conclusions contained in the software and documentation
# are those of the author and should not be interpreted as representing
# official policies, either expressed or implied, of anyone/thing else.
# ---------------------------------------------------------------------
# "Simplified BSD License" or "FreeBSD License"
# http://en.wikipedia.org/wiki/BSD_licenses
# ---------------------------------------------------------------------
# Note : a version of Proc::Daemon may be included in this package ;
# See the Proc::Daemon copyright notice.
# ---------------------------------------------------------------------

use strict ;
use warnings ;



package Blib ; ##############################################################

use Exporter ;
use Carp ;

our ( @EXPORT, @EXPORT_OK, @ISA ) ;
BEGIN
  { require Exporter ;
    @EXPORT    = qw() ;
    @EXPORT_OK = qw(mk_method mk_methods new_pack unref) ;
    @ISA       = qw(Exporter)
  }

our %LOGLEVELS =
  ( quiet   => 0
  , terse   => 1
  , verbose => 2
  , debug   => 3
  ) ;

our $MEEK = {} ;

sub unref ;
sub MEEK { $MEEK } ;
sub MEEK_incr
  { my $pack = unref shift ;
    $MEEK -> { $pack } { incr } ++ ;
  }
sub MEEK_decr
  { my $pack = unref shift ;
    $MEEK -> { $pack } { decr } ++ ;
  }
sub MEEK_dump
  { join '', map
      { my $incr = $MEEK -> { $_ } { incr } || 0 ;
        my $decr = $MEEK -> { $_ } { decr } || 0 ;
        sprintf "%6s %6s %s\n", $incr, $incr - $decr, $_ ;
      } sort keys %$MEEK ;
  }

# DESTROY { my $self = shift ; MEEK_decr ( $self ) ; }

sub unref { my $self = shift ; ref $self or $self ; }
sub _bless
  { my $val = shift ;
    my $pac = shift ;
#   MEEK_incr ( $pac ) ;
    bless $val, $pac ;
  }

sub _is_loglevel
  { my $self = shift ; my $cand = shift ; exists $LOGLEVELS { $cand } ; }
sub _loglevels
  { my $self = shift ;
    sort { $LOGLEVELS { $a } <=> $LOGLEVELS { $b } ; } keys %LOGLEVELS ;
  }

sub _pr
  { my @args = @_ ;
    if ( Blib::Mods -> can ( 'print' ) )
      { Blib::Mods::print ( @args ) ; }
    else
      { print @args ; }
  }

sub _pf
  { my @args = @_ ;
    if ( Blib::Mods -> can ( 'printf' ) )
      { Blib::Mods::printf ( @args ) ; }
    else
      { printf @args ; }
  }

sub _pr_hash
  { die "_pr_hash : need 2 args" unless @_ == 2 ;
    my $tag  = shift ;
    my $hash = shift ;
    _pf "%s :\n\{%s\n\}\n", $tag , join "\n, ", map
      { my $val = $hash -> { $_ } ;
        sprintf "%s=>%s", $_, ( defined $val ? $val : 'UNDEF' )
      } sort keys %$hash ;
  }

my %Opts = () ;
sub Opts
  { my $self = shift ;
    $Opts { $self } = { q => 0 , t => 0 , v => 0 , d => 0 , self => $self }
      unless exists $Opts { $self } ;
    $Opts { $self } ;
  }

sub dmp_opt
  { my $hash = shift ;
    sprintf "{%s}\n"
      , join ' , '
      , map { "$_=>$hash->{$_}" }
        ( 'self', sort grep { $_ ne 'self' } keys %{ $hash } ) ;
  }

my $level = 0 ;
sub lvl { my $lvl = shift ; $level = $lvl if defined $lvl ; $lvl ; }
sub xx1 { Blib::_pr ( @_ ) if $level > 0 ; }
sub xx2 { Blib::_pr ( @_ ) if $level > 1 ; }

sub _opt
  { my $self = shift ;
    my ( $recurse, $key, $val ) = @_ ;

    unless ( $self ) { xx1 "self empty ; result=0" ; return 0 ; }

    my $opts   = Opts $self ;
    my $parent = $self -> parent ;

    my $v = ( defined $val ? $val : '<undef>' ) ;
    xx1 "self ($self) key ($key) val ($v) recurse ($recurse)\n" ;
    xx1 dmp_opt $opts ;

    unless ( exists $opts -> { $key } )
      { Carp::confess "_opt : unknown option '$key'\n" ; }
    elsif ( defined $val )
      { Carp::confess "_opt : bad arg ($val)" if $val eq 'Blib' ;
        $opts -> { $key } = $val ;
        xx1 "set key ($key) val ($val)\n" ;
      }

    $val = $opts -> { $key } ;

    xx1 "key ($key) => val ($val)\n" ; xx1 dmp_opt ( $opts ) ;

    my $res = 0 ;
    if ( ! defined $val )
      { $res = 0 ;
        xx2 "undef\n" ;
      }
    elsif ( $val )
      { $res = $val % 2 ;
        xx2 sprintf "result ($val)\n" ;
      }
    elsif ( $recurse and $parent )
      { xx1 "recurse\n" ;
        $res = $parent -> _opt ( $recurse, $key, undef ) ;
      }
    else
      { xx2 "else ($val)\n" ; }
    xx1 "=> self ($self) key ($key) res ($res)\n" ;
    $res ;
  }

sub _dqv { my $self = shift ; xx1 "\n" ; $self -> _opt ( @_ ) ; }

sub quiet      { my $self = shift ; $self -> _dqv ( 1, 'q', shift ) ; }
sub quiet_me   { my $self = shift ; $self -> _dqv ( 0, 'q', shift ) ; }
sub terse      { my $self = shift ; $self -> _dqv ( 1, 't', shift ) ; }
sub terse_me   { my $self = shift ; $self -> _dqv ( 0, 't', shift ) ; }
sub verbose    { my $self = shift ; $self -> _dqv ( 1, 'v', shift ) ; }
sub verbose_me { my $self = shift ; $self -> _dqv ( 0, 'v', shift ) ; }
sub debug      { my $self = shift ; $self -> _dqv ( 1, 'd', shift ) ; }
sub debug_me   { my $self = shift ; $self -> _dqv ( 0, 'd', shift ) ; }

sub set_opts
  { my $self = shift ;
    my %opts = @_ ;
    if ( $opts{d} )
      { $self -> set_loglevel ( 'debug' ) ; }
    elsif ( $opts{v} )
      { $self -> set_loglevel ( 'verbose' ) ; }
    elsif ( $opts{q} )
      { $self -> set_loglevel ( 'quiet' ) ; }
    else
      { $self -> set_loglevel ( 'terse' ) ; }
  }

# parent '' is '' ; the parent of an object instance is it's class
sub parent
  { my $self = shift ;
    if ( ref $self )
      { ref $self ; }
    elsif ( $self =~ /^\w*$/ )
      { '' ; }
    elsif ( $self =~ /::\w+$/ )
      { $` ; }
    else
      { Carp::confess "parent : bad arg ($self)" ; }
  }

sub set_loglevel
  { my $self  = shift ;
    my $level = shift ;
    my $where = shift ;

    if ( Blib -> _is_loglevel ( $level ) )
      { my $mark = $LOGLEVELS { $level } ;
        for my $llvl ( keys %LOGLEVELS )
          { $self -> $llvl ( $LOGLEVELS { $llvl } <= $mark ) ; }
        Blib::_pf
          ( "set loglevel $self '%s' (%s)\n"
          , $level , ( $where || 'somewhere' )
          ) if $where or $self -> debug ;
      }
    else
      { Carp::confess "set_log_level : bad level ($level)" ; }
  }

sub new
  { my $self = shift ;
    my $name = shift ;
    if ( defined $name )
      { $self = "${self}::${name}" ;
        Carp::confess "Blib::new : bad name ($name)"
          if $name =~ /^Dbs|Tab|Rec|Mods$/ ;
        new_pack ( 'Blib', 'Mods' ) ;
        new_pack ( 'Blib', $name ) ;
        new_pack ( $self ) ;
      }
    _bless {}, $self ;
  }

sub make
  { my $self = shift ;
    my @args = @_ ;
    $self -> new -> init ( @args ) ;
  }

sub add_ISA
  { my $self = shift ;
    my $pack = shift ;
    my $isa  = sprintf 'push @%s::ISA, "%s" ;', $self, $pack ;
    Blib::_pr ( "\n# multiple inheritance for $self\n$isa\n\n" )
      if Blib -> debug ;
    my $res = eval "$isa 1 ;" ;
    Carp::confess "add_isa : $@" unless defined $res ;
    $res ;
  }

my %_dumped ;
my %_nodump ;
my $_verbos ;

sub _dmpval
  { my $self  = shift ;
    my $val   = shift ;
    my $depth = shift ;
    my $sep = ' ' x ( 2 * $depth ) ;
    
    my $dmp ;

    if ( ! defined $val )
      { $dmp = '<undef>' ; }
    elsif ( ref $val and eval { $val -> can ( 'dmp' ) } )
      { if ( exists $_dumped { $val } ) 
          { $dmp = "recursed ($val)" ; }
        else
          { $_dumped { $val } ++ ;
            $dmp = $val -> _dmp ( $depth + 1 ) ;
          } ;
      }
    elsif ( ref $val eq 'ARRAY' )
      { my $can = ( @$val and eval { $val -> [ 0 ] -> can ( 'dmp' ) } ) ;
        $dmp =
          ( scalar @$val
          ? sprintf "\n${sep}  [ %s\n$sep  ]"
              , join "\n$sep  , "
              , ( $can
                ? map { $_ -> _dmp ( $depth + 1 ) } @$val
                : @$val 
                ) 
          : '[]'
          ) ;
      }
    elsif ( ref $val eq 'HASH' )
      { $dmp =
          ( scalar keys %$val
          ? sprintf "\n${sep}  { %s\n$sep  }"
              , join "\n$sep  , "
              , map { sprintf "%s => %s", $_, $val -> { $_ } }
                  sort keys %$val
          : '{}'
          ) ;
      }
    elsif ( ! ref $val and $val eq '' )
      { $dmp = '<empty>' ; }
    else
      { $val =~ s/(ARRAY|HASH)\(\w+\)/$1/ ;
        $dmp = $val ;
      }
    $dmp ;
  }

sub _dmp
  { my $self  = shift ;
    my $depth = shift ;
    my $ref = ref $self ;
    %_dumped = () if $depth == 0 ;
    my $sep = ' ' x ( 2 * $depth ) ;
    my $slf = $depth ? '' : 'self ' ;
    my $res = sprintf "%sis a '%s'\n", $slf, $ref ;
    $res .= sprintf "${sep}ISA (%s)\n", eval '@' . "${ref}::ISA" ;
    my $w = 0 ;
    if ( ref $self and $self =~ /HASH/ )
      { for my $key ( keys %$self ) { $w = length $key if length $key > $w ; }
        for my $key ( sort keys %$self )
          { my $val = $self -> { $key } ;
            my $dmp ;
            if ( $_nodump { $key } )
              { next unless $_verbos ; $dmp = "<excluded> $val" ; }
            else
              { $dmp = $self -> _dmpval ( $val, $depth ) ; }
            my $nl = ( "\n" eq substr ( $dmp, -1, 1 ) ? '' : "\n" ) ;
            $res .= sprintf "%s%-${w}s : %s%s" , $sep , $key , $dmp, $nl ;
          }
      }
    elsif ( ref $self and $self =~ /ARRAY/ )
      { my $can = ( @$self and eval { $self -> [ 0 ] -> can ( 'dmp' ) } ) ;
        $res .=
          ( scalar @$self
          ? sprintf "${sep}  [ %s\n$sep  ]"
             , join "\n$sep  , "
             , ( $can
               ? map { $_ -> _dmp ( $depth + 1 ) } @$self
               : @$self
               )
          : '[]'
          ) ;
      }
    $res ;
  }

sub dmp
  { my $self = shift ;
    my %opts =
      ( -excl => [ qw(_cafe _tabl _base) ]
      , -incl => []
      , -verb => 1
      , @_
      ) ;
    %_dumped = () ;
    %_nodump = () ;
    $_verbos = $opts { -verb } ;
    for my $key ( @{ $opts { -excl } } ) { $_nodump { $key } ++ ; }
    for my $key ( @{ $opts { -incl } } ) { delete $_nodump { $key } ; }
    Blib::_pf ( "excluding [%s]\n", join ',', sort keys %_nodump ) if $_verbos ;
    Blib::_pr ( $self -> _dmp ( 0 ) ) ;
  }

sub _getset
  { my $self = shift ;
    my $attr = shift ;
    Carp::confess "self not ref ($self)" unless ref $self ;
    if ( @_ ) { $self -> { $attr } = shift ; }
    Carp::confess "no attr '$attr' ($self)" unless exists $self -> { $attr } ;
    my $res = $self -> { $attr } ;
    ( wantarray and ref $res eq 'ARRAY' ) ? @$res : $res ;
  }

sub mk_typ
  { my $self = shift ;
    my $d = shift ;
    my $type = ref $self || $self ;
    die "mk_typ : bad type ($type)"
      unless $type =~ /Blib::(Dbs|Tab|Col|Rec)(::|$)?/ ;
    my $s = ( split /::/, $type ) [ 1 ] ;
    $type =~ s/$s/$d/ ;
    $type ;
  }

sub mk_method
  { my $self = shift ;
    my $attr = shift ;
    sprintf 'sub %s { my $self = shift ; $self -> _getset ( "%s",  @_ ) ; }'
      , $attr, $attr ;
  }

sub mk_methods
  { my $self = shift ;
    join "\n", map { Blib -> mk_method ( $_ ) ; } @_ ;
  }

sub new_pack
  { my $type = shift ;
    my $name = shift ;
    my @isa  = split /::/, $type ;
    my $isa  = shift @isa ; $isa .= '::' . shift @isa if @isa ;
    my $new_typ = $type ;
    my $new_isa = $isa  ;
    if ( defined $name )
      { $new_typ = "${type}::${name}" ; $new_isa = $type ; }
    my $fmt  = <<'PACK' ;

{ package %s ; }
{ @%s::ISA = qw(%s) ; }
PACK
    my $pack = sprintf $fmt, $new_typ, $new_typ, $new_isa ;
    Blib::_pr $pack if Blib -> debug ;
    my $res = eval "$pack ; 1 ;" ;
    Carp::confess "new_pack : $@" unless defined $res ;
    $pack ;
  }

sub new_method
  { my $pack = shift ;
    my $attr = shift ;
    my $fmt  = "{ package %s ; eval Blib -> mk_method ( '%s' ) ; }\n" ;
    my $mth = sprintf $fmt, $pack, $attr, $attr ;
    Blib::_pr ( $mth ) if Blib -> debug ;
    my $res = eval "$mth ; 1 ;" ;
    Carp::confess "new_method : $@" unless defined $res ;
  }

### JSON ####################################################################

package Blib::JSON ;

our @ISA ; BEGIN { @ISA = qw(Blib) ; }

eval Blib -> mk_methods ( qw(__) ) ;

my %name4key ;
sub add_name4key
  { my $self = shift ;
    my %opts = @_ ;
    for my $key ( keys %opts ) { $name4key { $key } = $opts { $key } ; }
  }
sub name4key
  { my $self = shift ;
    my $x = shift ;
    $name4key { $x } || $x ;
  }

my %name4row ;
sub add_name4row
  { my $self = shift ;
    my %opts = @_ ;
    for my $key ( keys %opts )
      { $name4row { $key } = $opts { $key } ; }
  }
sub name4row
  { my $self = shift ;
    my $x = shift ;
    my $n = $x ;
    $n =~ s/=.*// ;
    $name4row { $n } ;
  }

sub make
  { my $self = shift ;
    my %opts = @_ ;
    my $name = $opts { -name } ;
    $self -> new ( $name ) -> init ( %opts ) ;
  }

sub init
  { my $self = shift ;
    my %opts = @_ ;
    $self -> __ ( undef ) ;
    for my $opt ( keys %opts ) { $self -> $opt ( $opts { $opt } ) ; }
    $self ;
  }

sub add
  { my $self = shift ;
    my $type = Blib::unref $self ;
    my %opts = @_ ;
    my $name = $opts { -name } ;
    my $kind = $opts { -kind } ;
    my $tsub = "${type}::$name" ;

    Blib::new_method ( $type, $name ) ;
    Blib::new_pack ( $tsub ) if $kind ;
    my $res = Blib::_bless {}, $tsub ;
    if ( ref $self )
      { $self -> { $name } = ( $kind ? $res : 'scalar' ) ; }
    $res ;
  }

sub mk_sub_model ;

sub mk_sub_model
  { my $self = shift ;
    my $base = shift ;
    my $name = shift ;
    my $json = shift ;
    my $kind = ref $json ;

    my $type = $base -> add ( -name => $name , -kind => $kind ) ;

    if ( $kind eq 'HASH' )
      { for my $key ( sort keys %$json )
          { my $name = Blib::JSON -> name4key ( $key ) ;
            $self -> mk_sub_model ( $type, $name, $json -> { $key } ) ;
          }
      }
    elsif ( $kind eq 'ARRAY' and @$json )
      { my $elem = $json -> [ 0 ] ;
        my $name = Blib::JSON -> name4row ( $type ) ;
        die "no name for $type" unless $name ;
        $self -> mk_sub_model ( $type, $name, $elem ) ;
      }

    $type ;
  }

sub mk_model
  { my $self = shift ;
    my $name  = shift ;
    my $json  = shift ;
    $self -> mk_sub_model ( 'Blib::JSON', $name, $json ) ;
  }

sub bless
  { my $type = shift ;
    my $json = shift ;
    my $kind = ref $json ;

    Blib::_bless ( $json, Blib::unref $type ) ;

    if ( $kind eq 'HASH' )
      { for my $key ( sort keys %$json )
          { my $name = Blib::JSON -> name4key ( $key ) ;
            if ( $name ne $key )
              { $json -> { $name } = $json -> { $key } ;
                delete $json -> { $key } ;
              }
            if ( ref $type -> $name )
              { $type -> $name -> bless ( $json -> { $name } ) ; }
          }
      }
    elsif ( $kind eq 'ARRAY' and @$json and ref ( $json -> [ 0 ] ) )
      { my $name = Blib::JSON -> name4row ( $type ) || 'elem' ;
        for my $elem ( @$json )
          { $type -> $name -> bless ( $elem ) ; }
      }

    $json ;
  }

1 ;

package main ;
# --------------------------------------------------------------------------


our $LCL_JSON ;

BEGIN
  { my @jsons = qw(JSON::XS JSON::PP JSON) ;
    for ( @jsons )
      { if ( eval "use $_ ; 1 ;" )
          { $LCL_JSON = $_ ; last ; }
      }
    die sprintf "can't find %s\n", join ' or ', @jsons
      unless defined $LCL_JSON ;
    die sprintf "%s can't do 'new()'\n", $LCL_JSON
      unless $LCL_JSON -> can ( 'new' ) ;
  }

BEGIN { Blib -> import () ; }
use Carp ;
use File::Path ;

our $PRG     = 'iim' ;
our $VERSION = '0.4.10' ;

our $DEV   = 0 ;
our $INO   = 1 ;
our $NLINK = 3 ;
our $SIZE  = 7 ;
our $ATIME = 8 ;
our $MTIME = 9 ;

our $MAX_TRIES    = 3 ;
our $LOCK_TRIES   = 3 ;
our $LOCK_SLEEP   = 1 ;
our $LCK_FILE     = "iim.lck" ;
our $LOG_FILE     = "iim.log" ;
our $PID_FILE     = "iim.pid" ;
our $SCB_FILE     = "iim-scb.html" ;
our $SCB_TMPL     = "iim-scb-tmpl.html" ;
our $SCB_SMPL     = "$SCB_TMPL.sample" ;
our $REQ_LIST     = 'request-list' ;
our $MAX_AGE_INIT = '2d' ;
our $REOPEN_IVAL  = 300;
our $SLEEP_NAP    = 15 ;
our $AGGREGATOR   = [ qw(1h 6h 1d 1W 1M 1Q 1Y Z) ] ;
our $UMASK        = '022' ;
our $CPAN_LOCL    = 'local' ;
our $CPAN_TEMP    = "$CPAN_LOCL/iim" ;
our $RSYNC_TMP    = 'rsync-tmp' ;
our $HOSTNAME     = `hostname 2>/dev/null` ;
our $IIM_SITE     = 'http://www.staff.science.uu.nl/~penni101/iim' ;
our $IIM_LOGO     = 'iim-logo.png' ;
our $IIM_LOGO_URL = "$IIM_SITE/images/$IIM_LOGO" ;
our $STAMP        = 'indices/timestamp.txt' ;

our @RSYNC_OPTS =
  ( '--no-motd'
  , '-a'
  , '--stats'
  , '-z'
  , '--exclude' => "/$CPAN_LOCL/"
  ) ;

our @RSYNC_LIST =
  ( @RSYNC_OPTS
  ) ;

our @RSYNC_FULL =
  ( @RSYNC_OPTS
  , '-v'
  , '--delete'
  ) ;

our @RSYNC_CMP =
  ( @RSYNC_FULL
  , '-n'
  , '--timeout' => 300
  ) ;

our $NOERR =  0 ;
our $E_XEC = 11 ;
our $E_SIG = 12 ;
our $E_XIT = 13 ;
our $E_PRT = 23 ; # Partial transfer due to error
our $E_MIS = 24 ; # Partial transfer due to vanished source files

sub PRG      { $PRG ;      }
sub SCB_FILE { $SCB_FILE ; }
sub SCB_TMPL { $SCB_TMPL ; }
sub SCB_SMPL { $SCB_SMPL ; }
sub LCL_JSON { $LCL_JSON ; }

##########################################################
package RF ;

use Time::HiRes qw(gettimeofday) ;
use Fcntl qw(:flock) ;
use IO::Pipe ;

our ( @ISA, @EXPORT ) ;
BEGIN
  { require Exporter ;
    @ISA    = qw(Blib) ;
    @EXPORT = qw(LOGf LOGx) ;
  }

my @methods =
  ( qw( conf type epoc next_sync next_reopen next_rotate tag scores)
  , qw( sync status)
  ) ;
eval Blib -> mk_methods ( @methods ) ;

our $name4key =
  { '$0' => 'dollar0'
  , 'File::Rsync::Mirror::Recentfile' => 'FRMR'
  } ;
our $name4row =
  { 'Blib::JSON::rfile::recent'           => 'event'
  , 'Blib::JSON::rfile::meta::aggregator' => 'interval'
  } ;

sub LOGx
  { my $x = shift ;
    my $date = localtime ;
    printf "%s %s\n", $date, $x ;
  }

sub LOGf
  { my $f = shift ;
    my $date = localtime ;
    my $msg  = sprintf $f, @_ ;
    printf "%s %s\n", $date, $msg ;
  }

sub loglevel
  { my %opts = @_ ;
    my $res ;
    $res = $opts { loglevel } if exists $opts { loglevel } ;
    $res = 'quiet'   if $opts{q} ;
    $res = 'verbose' if $opts{v} ;
    $res = 'debug'   if $opts{d} ;
    $res ;
  }

sub init
  { my $self = shift ;
    my %opts =
      ( -root => undef
      , @_
      ) ;
    my $llvl = loglevel %opts ;
    $self -> set_loglevel ( $llvl )
      if $llvl and Blib -> _is_loglevel ( $llvl ) ;
    $opts { loglevel } = $llvl if $llvl ;

    my $conf = $self -> conf ( $self -> get_config ( %opts ) ) ;
    die $conf unless ref $conf ;
    $self -> set_loglevel ( $conf -> loglevel ) unless $llvl ;

    $ENV { RSYNC_PASSWORD } = $conf -> passwd ;
    Blib::JSON -> add_name4key ( %$name4key ) ;
    Blib::JSON -> add_name4row ( %$name4row ) ;
    my $json =
     ( $conf -> model_file
     ? $self -> _get_json ( $conf -> model_file )
     : $LCL_JSON -> new -> decode ( $conf -> model )
     ) ;
    $self -> type ( Blib::JSON -> mk_model ( 'rfile', $json ) ) ;
    $self -> epoc ( undef )    ; # undef == 'no epoch determined'
    $self -> tag  ( undef )    ; # undef == 'plain mode'
    $self -> next_sync   ( 0 ) ; # 0 == 'nothing scheduled'
    $self -> next_rotate ( 0 ) ; # will rotate if rotate.count > 0
    $self -> next_reopen ( 0 ) ;
    $self -> scores ( RF::Scores -> make ( parent => $self ) ) ;
    $self -> sync ( RF::Sync -> make ( parent => $self ) ) ;
    $self -> status ( 'initializing' ) ;
    $self -> set_umask ;
    $self ;
  }

sub dtag
  { my $self = shift ;
    my $tag   = $self -> tag || '' ;
    substr $tag, 1 + rindex $tag, '/' ;
  }

sub config_list
  { my $self = shift ;
    my $home = ( getpwuid $< ) [ 7 ] or die "can get homedir '$<' ($!)" ;
      ( "$PRG.conf", "$home/.$PRG.conf", "/etc/$PRG.conf", '/dev/null' ) ;
  }

sub get_config
  { my $self = shift ;
    my %opts = @_ ;
    my $root = $opts { -root } ;
    unless ( defined $root )
      { $root = ( grep { -f $_ || -c $_ ; } $self -> config_list ) [ 0 ] ;
        if ( $root )
          { $opts { -root } = $root ; }
        else
          { die sprintf "can't find a config file :\n  %s\n"
              , join "\n  ", $self -> config_list ;
          }
      }

    # now we have a root in $opts{-root}

    Blib::Mods::Conf -> make ( -parent => $self, %opts ) ;
  }

sub try_reload_conf
  { my $self = shift ;
    my %opts = @_ ;
    my $conf = $self -> conf ;
    if ( $conf -> hot_config and $conf -> touched )
      { RF::LOGx "config touched" ;
        my $root = $conf -> root ;
        my $new_conf = $self -> get_config ( -root => $root, %opts ) ;
        if ( ref $new_conf )
          { $conf = $self -> conf ( $new_conf ) ;
            $conf -> show ( '  ' ) ;
            $self -> set_loglevel ( $conf -> loglevel, 'reload' ) ;
            RF::LOGx "config reloaded" ;
          }
        else
          { chomp ( my $err = $new_conf ) ;
            $self -> conf -> show ( '  ' ) ;
            RF::LOGx $err ;
            RF::LOGx "no new config loaded" ;
          }
      }
  }

sub mode { my $self = shift ; $self -> tag ? 'daemon' : 'plain' ; }

sub req_file
  { my $self = shift ;
    sprintf "%s/%s.%s" , $self -> conf -> temp, $REQ_LIST
      , ( $self -> dtag || 'term' ) ;
  }

sub put_req_file
  { my $self = shift ;
    my $list = shift ;
    my $file = $self -> req_file ;
    open FILE, ">$file" or die "put_req_file $file : fail ($!)" ;
    printf FILE "%s\n", join "\n", @$list ;
    close FILE ;
  }

sub next_status
  { my $self = shift ;
    my $stat = shift ;
    my $push = shift ;
    my $prev = $self -> status ;
    $self -> status ( $stat ) ;
    $self -> scores -> put_scoreboards if $push ;
    $prev ;
  }

sub status_html
  { my $self = shift ;
    my $stat = $self -> status ;
    $stat eq 'looping' ? $stat : "<SPAN CLASS=\"iim_red\">$stat</SPAN>" ;
  }

sub age
  { my $self = shift ;
    my $stmp = $self -> path ( 'local', $STAMP ) ;
    my $res  = 'undef' ;
    if ( open STMP, $stmp )
      { my $line = <STMP> ;
        my $time = ( split ' ', $line ) [ 0 ] ;
        if ( $time =~ /^\d+$/ )
          { $res = $self -> conf -> _text4secs ( time - $time, 0 ) ; }
        close STMP ;
      }
    $res ;
  }

sub xlock
  { my $self = shift ;
    my $file = shift ;
    my $cnt  = 0 ;
    my $res  = 0 ;

    unless ( open LOCK, ">$file" )
      { LOGx "can't write lock $file" ; exit ; }
    while ( $cnt < $LOCK_TRIES )
      { if ( flock LOCK, LOCK_EX|LOCK_NB )
          { $res = 1 ; last ; }
        $cnt ++ ;
        sleep $LOCK_SLEEP ;
      }
    $res ;
  }

sub start_daemon
  { my $self = shift ;
    my $name = shift ;
    my $prog = $self -> conf -> prog_iim || 'no-such-file' ;
    my @args = @_ ;
    my $pid ;

    if ( ! defined $prog or ! -f $prog )
      { if ( $self -> terse )
          { LOGf "can't find file '%s' ; daemon can't run.", $prog ;
            LOGf "suggestion : configure option 'prog_iim'."
          }
        $self -> _exit ( 1, "can't find $prog" ) ;
      }

    unless ( -d $name or mkdir $name, 0755 )
      { LOGx "can't mkdir $name ($!)" ; $self -> _exit ( 1 ) ; }

    unless ( $self -> xlock ( "$name/$LCK_FILE" ) )
      { LOGx "can't lock ; daemon '$name' is already running"
          if $self -> terse ;
        $self -> _exit ;
      }

    my $daemon = Proc::Daemon -> new
      ( work_dir     => '.'
      , exec_command =>
          ( sprintf 'perl %s %s' , $prog, join ' '
              , grep { ! /^--?q$/ ; }
                map { /^--?daemon$/ ? '--tag' : $_ ; }
                @args
          )
      , child_STDOUT => ">>$name/$LOG_FILE"
      , child_STDERR => ">>$name/$LOG_FILE"
      , pid_file     => "$name/$PID_FILE"
      ) ;

    if ( -f "$name/$PID_FILE"
     and $pid = $daemon -> Status ( "$name/$PID_FILE" )
       )
      { LOGx "iim '$name' is already running ; pid $pid"
          if $self -> terse ;
      }
    else
      { $pid = $daemon -> Init () ;
        LOGx "started iim daemon '$name' ; pid $pid" ;
      }
  }

sub be_the_daemon
  { my $self = shift ;
    my $name = shift ;
    unless ( $self -> xlock ( "$name/$LCK_FILE" ) )
      { LOGx "can't lock ; can't be the daemon" ;
        $self -> _exit ;
      }
    $self -> tag ( $name ) ;
    $self -> reopen_log ;
  }

sub _sleep
  { my $self = shift ;
    my $ival = shift ;
    my $time = $self -> conf -> $ival ;
    LOGx "sleeping $time ($ival) ..." if $self -> debug ;
    $self -> scores -> put_scoreboards ;
    $self -> scores -> incr_t_slp ( $time ) ;
    sleep $time ;
  }

sub _exit
  { my $self = shift ;
    my $stat = shift || 0 ;
    my $diag = shift || '' ;
    my $mesg = "exit ($stat)" . ( $diag ? " - $diag" : '' ) ;
    LOGx $mesg if $self -> terse ;
    $self -> status ( $mesg ) ;
    $self -> scores -> put_scoreboards if $self -> terse ;
    exit $stat ;
  }

sub set_umask
  { my $self = shift ;
    my $umask = oct $self -> conf -> iim_umask ;
    my $pmask = umask $umask ;
    LOGf "set umask 0%o -> 0%o", $pmask, $umask
      if $umask != $pmask and $self -> debug ;
  }

sub check_max_run_time
  { my $self = shift ;
    my $max  = $self -> conf -> max_run_time ;
    if ( $max and time >= $^T + $max )
      { LOGx "scheduled exit" ; $self -> _exit }
  }

sub log_next_exit
  { my $self = shift ;
    my $max  = $self -> conf -> max_run_time ;
    LOGx
      ( $max
      ? sprintf 'exit scheduled at %s', scalar localtime $^T + $max
      : 'no exit is scheduled'
      ) ;
  }

sub want_rotate_now
  { my $self  = shift ;
    my $count = $self -> conf -> rotate -> { count } ;
    $self -> tag and $count and time > $self -> next_rotate ;
  }

sub _rotate_logs
  { my $self = shift ;
    my $log  = shift ;
    my $cnt  = $self -> conf -> rotate -> { count } ;
    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 LOGx "can't rename $src, $dst"
          if -f $src ;
      }
    my $dst = "$log.1" ;
    rename $log, $dst or LOGx "can't rename $log, $dst" if -f $log ;
  }

sub want_reopen_now
  { my $self = shift ; $self -> tag and time > $self -> next_reopen ; }

sub reopen_log
  { my $self = shift ;
    my $tag  = $self -> tag ;
    if ( $tag )
      { my $log = "$tag/$LOG_FILE" ;
        if ( $self -> want_rotate_now )
          { LOGx "rotate $log" if $self -> terse ;
            $self -> _rotate_logs ( $log ) ;
            $self -> next_rotate
              ( time + $self -> conf -> rotate -> { ival } ) ;
          }
        LOGx "reopen_log $log" if $self -> debug ;
        close STDOUT ;
        unless ( open STDOUT, ">>$log" )
          { printf STDERR
              "re_open_log : can't write $log (again) for STDOUT ; exit\n" ;
            $self -> _exit ( 1 ) ;
          }
        close STDERR ;
        unless ( open STDERR, '>>&STDOUT' )
          { printf STDOUT
              "re_open_log : can't write $log (again) for STDERR ; exit\n" ;
            $self -> _exit ( 1 ) ;
          }
        select STDERR ; $| = 1 ;
        select STDOUT ; $| = 1 ;
        $self -> next_reopen ( time + $REOPEN_IVAL ) ;
      }
  }

sub set_next_full
  { my $self = shift ;
    my $ival = shift || 'full_sync_interval' ;
    if ( $self -> conf -> full_sync_interval )
      { my $next = time + $self -> conf -> $ival ;
        LOGf ( "full sync scheduled at %s", scalar localtime $next ) ;
        $self -> next_sync ( $next ) ;
      }
    else
      { $self -> next_sync ( 0 ) ; }
    $self -> next_sync ;
  }

sub want_full_now
  { my $self = shift ;
    if ( $self -> conf -> full_sync_interval )
      { my $next = $self -> next_sync ; $next and time > $next ; }
    else
      { 0 ; }
  }

sub version { sprintf '%s-%s', $PRG, $VERSION ; }
sub Version { sprintf '%s version %s', $PRG, $VERSION ; }

sub mk_temps
  { my $self = shift ;
    my $conf = $self -> conf ;
    use File::Path qw(mkpath rmtree) ;
    my $temp = $conf -> temp ;
    mkpath $temp ; # or die
    for my $dir ( $conf -> rtmp )
      { rmtree $dir if -d $dir ;
        mkdir $dir, 0777 or die "can't mkdir $dir ($!)" ;
      }
    my $logo_dst = $self -> path ( 'temp', $IIM_LOGO ) ;
    my $tmpl_dst = $self -> path ( 'temp', $SCB_SMPL ) ;
    Logo -> save_as ( $logo_dst ) ;
    Tmpl -> save_as ( $tmpl_dst ) ;
  }

sub _get_json
  { my $self = shift ;
    my $file = shift ;
    open FILE, $file or Carp::confess ( "can't open json '$file' ($!)" ) ;
    my $json = $LCL_JSON -> new -> decode ( join '', <FILE> ) ;
    close FILE ;
    $json ;
  }

sub get_json
  { my $self = shift ;
    my $file = shift ;
    my $json = $self -> _get_json ( $file ) ;
    $self -> type -> bless ( $json ) ;
  }

sub name_recent_file
  { my $self = shift ;
    my $interval = shift || $AGGREGATOR -> [ 0 ] ;
    sprintf "RECENT-%s.json", $interval ;
  }

sub all_Recents
  { my $self = shift ;
    [ map { $self -> name_recent_file ( $_ ) ; } @$AGGREGATOR ] ;
  }

sub have_all_Recents
  { my $self = shift ;
    my $res = 1 ;
    for my $name ( @{ $self -> all_Recents } )
      { $res = 0 unless $self -> lstt ( 'local', $name ) ; }
    LOGx "some Recents are missing ..." unless $res ;
    $res ;
  }

sub get_Recents
  { my $self = shift ;
    my $conf = $self -> conf ;
    my %inos = () ;
    my $names =  $self -> all_Recents ;
    my $res ;
    for my $name ( @$names )
      { $inos { $name } = $self -> temp_ino ( $name ) ; }

    $res = $self -> get_remote ( $names, 'r' ) ;

    for my $name ( @$names )
      { my $old = $inos { $name } ;
        my $new = $self -> temp_ino ( $name ) ;
        my $dst = $self -> path ( 'temp', $name ) ;
        Carp::confess ( "get_Recents: bad dst ($dst)" ) unless -f $dst ;
        unless ( defined $old )
          { Carp::confess ( "get_Recents: undefined ino old" ) }
        elsif ( ! defined $new )
          { Carp::confess ( "get_Recents: undefined ino new" ) }
        elsif ( $old != $new )
          { my $size = -s $dst ;
            $self -> scores -> incr_fetf ;
            $self -> scores -> incr_fetr ;
            $self -> scores -> incr_s_fil ( $size ) ;
            $self -> scores -> incr_s_rct ( $size ) ;
          }
      }
    $res ;
  }

sub get_Recents_repeat
  { my $self = shift ;
    my $cnt  = 0 ;
    while ( ! $self -> get_Recents )
      { LOGx "get_Recents failed ; sleeping ..." ;
        $self -> _sleep ( ++ $cnt < 3 ? 'nap' : 'sleep_main_loop' ) ;
      }
  }

sub link_Recents
  { my $self = shift ;
    LOGx "link_Recents: link local in temp" if $self -> debug ;
    for my $name ( @{ $self -> all_Recents } )
      { my $src  = $self -> lstt ( 'local', $name ) ;
        my $dst  = $self -> path ( 'temp',  $name ) ;
        if ( $src )
          { unlink $dst ; link $src, $dst ; }
        else
          { LOGx "link_Recents: no src for $dst" ; }
      }
  }

sub move_Recent
  { my $self = shift ;
    my $name = shift ;
    my $src = $self -> conf -> temp  . "/$name" ;
    my $dst = $self -> conf -> local . "/$name" ;

    unless ( -f $src )
      { LOGx "move_Recent: no $src" ; }
    elsif ( ! -f $dst )
      { LOGx "move_Recent: no $dst" ; }
    else
      { my ( $i_src, $t_src ) = ( stat $src ) [ $INO, $MTIME ] ;
        my ( $i_dst, $t_dst ) = ( stat $dst ) [ $INO, $MTIME ] ;

        if ( $i_src != $i_dst and $t_src > $t_dst )
          { unlink $dst ;
            link $src, $dst ;
            LOGx "move from temp to local : $name"
              if $self -> verbose or $name !~ /^RECENT-\dh\.json$/ ;
          }
      }
  }

sub move_Recents
  { my $self = shift ;
    for my $name ( @{ $self -> all_Recents } )
      { $self -> move_Recent ( $name ) ; }
  }

sub by_epoch { $b -> { epoch } <=> $a -> { epoch } ; }
sub merge { my $self = shift ; [ sort by_epoch map { ( @$_ ) ; } @_ ] ; }

sub log_sync_stat
  { my $self = shift ;
    my $stat = shift ;
    my $tag  = shift ;
    my $sig  = ( $stat & 127 ) ;
    my $xit  = ( $stat >> 8  ) ;

    if ( $stat == -1 )
      { LOGx "$tag: failed to execute: $!" ; }
    elsif ( $sig )
      { LOGx "$tag: child died on signal $sig" ; }
    elsif ( $xit )
      { LOGx "$tag: child exited with value $xit" ; }
  }

sub get_remote
  { my $self = shift ;
    my $fils = shift ;
    my $kind = shift || '' ; # 'r' for Recents
    my $conf = $self -> conf ;
    my $sync = $self -> sync ;
    my $prev = $self -> next_status ( 'syncing' ) ;

    $self -> scores -> incr_rs ;
    $sync -> request ( $fils, $kind ) ;

    my $time = $sync -> timer ;
    my $err  = $sync -> error ;

    if ( $err == -1 )
      { RF::LOGf "Sync::open : no pipe for %s", $sync -> cmd ; }
    elsif ( $err )
      { $self -> log_sync_stat ( $err, 'get_remote' ) ;
        $self -> scores -> incr_rsf ;
        $self -> scores -> incr_t_out ( $time ) ;
      }
    else
      { $self -> scores -> incr_t_con ( $time ) ; }

    $self -> next_status ( $prev ) ;

    ! $err ;
  }

sub full_sync
  { my $self = shift ;
    my $doit = shift ;
    my $conf = $self -> conf ;
    my $sync = $self -> sync ;
    my $prev = $self -> next_status ( 'full sync', 'push' ) ;

    unless ( $doit or $self -> conf -> allow_full_syncs )
      { LOGx "full_sync : not allowed " ; $self -> _exit ( 1 ) ; }
    LOGx 'full sync start' ;
    $self -> scores -> incr_frs ;

    my $err  = $sync -> full  ;
    my $time = $sync -> timer ;

    if ( $err )
      { $self -> log_sync_stat ( $err, 'full sync' ) ;
        $self -> scores -> incr_t_out ( $time ) ;
        $self -> scores -> incr_frsf ;
      }
    else
      { LOGx 'full sync: ok' ; $self -> scores -> incr_t_frs ( $time ) ; }

    $self -> next_status ( $prev ) ;

    ! $err ;
  }

sub full_sync_repeat
  { my $self = shift ;
    my $doit = shift ;
    my $prev = $self -> next_status ( 'full syncs until success' ) ;
    LOGx "doing full syncs until one succeeds" ;
    while ( ! $self -> full_sync ( $doit ) )
      { LOGx "full sync failed ; sleeping ..." ;
        $self -> _sleep ( 'sleep_init_epoch' ) ;
      }
    $self -> next_status ( $prev ) ;
  }

sub compare
  { my $self = shift ;
    my $conf = $self -> conf ;
    my $sync = $conf -> prog_rsync ;
    my $user = $conf -> user ? $conf -> user . '@' : '' ;
    my $remo = $user . $conf -> remote ;
    my $locl = $conf -> local  ;
    my @cmd  = ( $sync , @RSYNC_CMP , $remo , $locl ) ;
    LOGf "%s\n", join ' ', @cmd ;
    exec @cmd ;
  }

sub path
  { my $self = shift ;
    my $tree = shift ;
    my $path = shift ;
    sprintf "%s/%s", $self -> conf -> $tree, $path ;
  }

sub lstt
  { my $self = shift ;
    my $tree = shift ;
    my $path = shift ;
    my $file = $self -> path ( $tree, $path ) ;
    ( lstat $file ) ? $file : undef ;
  }

sub in_locl { my $self = shift ; $self -> lstt ( 'local', $_[0] ) ; }
sub in_temp { my $self = shift ; $self -> lstt ( 'temp',  $_[0] ) ; }

sub get_EPOCH_local_or_remote
  { my $self = shift ;
    my $src  = shift ;
    die "get_EPOCH_local_or_remote : bad src ($src)"
      unless $src eq 'remote' or $src eq 'local' ;
    my $name = $self -> name_recent_file ;
    my $res ;
    while ( ! $res and $name )
      { my $file =
          ( ( $src eq 'remote' )
          ? $self -> in_temp ( $name )
          : $self -> in_locl ( $name )
          ) ;
        return undef unless defined $file ;
        my $json   = $self -> get_json ( $file ) ;
        my $events = $json -> recent ;
        my $next   =
          ( exists $json -> meta -> { merged }
          ? $json -> meta -> merged -> into_interval
          : undef
          ) ;
        if ( @$events )
          { $res = $events -> [ 0 ] -> epoch ; }
        elsif ( ! defined $next )
          { LOGx "no next in $name" ; return undef ; }
        else
          { $name = $self -> name_recent_file ( $next ) ; }
      }
    $res ;
  }

sub get_EPOCH_remote
  { my $self = shift ;
    $self -> get_Recents_repeat ;
    $self -> get_EPOCH_local_or_remote ( 'remote' ) ;
  }

sub get_EPOCH_local
  { my $self = shift ; $self -> get_EPOCH_local_or_remote ( 'local'  ) ; }

sub set_epoch
  { my $self = shift ;
    my $epoc = shift ;
    LOGf "set EPOCH %s", $epoc ;
    $self -> epoc ( $epoc ) ;
    $epoc ;
  }

sub _init_epoch
  { my $self = shift ;
    my $conf = $self -> conf ;
    my $ival = $conf -> max_age_init ;
    my $res  = undef ;

    my $epoc_r = $self -> get_EPOCH_remote ;

    if ( ! $epoc_r )
      { LOGx "can't get epoch from remote" ; }
    else
      { LOGx $conf -> age4epoc ( 'remote', $epoc_r ) ;
        my $epoc_l = $self -> get_EPOCH_local ;
        if ( ! $epoc_l or $epoc_r - $epoc_l > $ival )
          { if ( $epoc_l )
              { my $itxt = $conf -> _text4secs ( $ival, 0 ) ;
                LOGx $conf -> age4epoc ( 'local', $epoc_l ) ;
                LOGx "remote is more than $itxt ahead" ;
              }
            else
              { LOGx "no local epoch" ; }
            $self -> full_sync_repeat ;
          }
        else
          { LOGx $conf -> age4epoc ( 'local', $epoc_l ) ;
            LOGx 'set epoch from local' ;
            $res = $epoc_l ;
          }
      }
    $res ;
  }

sub init_epoch
  { my $self = shift ;
    my $epoc =  $self -> _init_epoch ;
    while ( ! defined $epoc )
      { $self -> _sleep ( 'sleep_init_epoch' ) ;
        $epoc = $self -> _init_epoch ;
      }
    $self -> set_epoch ( $epoc ) ;
  }

sub mtime { my $self = shift ; ( lstat $_ [ 0 ] ) [ $MTIME ] ; }
sub nlink { my $self = shift ; ( lstat $_ [ 0 ] ) [ $NLINK ] ; }
sub lsize { my $self = shift ; ( lstat $_ [ 0 ] ) [ $SIZE  ] ; }
sub ino   { my $self = shift ; ( lstat $_ [ 0 ] ) [ $INO   ] ; }
sub is_dir { my $self = shift ; my $name = shift ; lstat $name ; -d _ ; }
sub temp_ino
  { my $self = shift ;
    my $path = shift ;
    $self -> ino ( $self -> path ( 'temp', $path ) ) ;
  }

sub events_since_ival
  { my $self = shift ;
    my $ival = shift ;
    my $epoc = $self -> epoc ;
    my $name = $self -> name_recent_file ( $ival ) ;
    my $res  ;
    my $rec  = [] ;
    my $file = $self -> in_temp ( $name ) ;
    if ( defined $file )
      { my $json = $self -> get_json ( $file ) ;
        my $events = $json -> recent ;
        for my $event ( @$events )
          { $event -> init ( base => $self, ival => $ival ) ; }
        # recurse if all events (if any) are older than $epoc
        # event are ordered new to old ; the last is eldest
        # meta -> merged does not exist in Z ; it should be 'merged:null'
        my $e_cnt = @$events ;
        if ( ( $e_cnt == 0 or $epoc < $events -> [ $e_cnt - 1 ] -> epoch )
         and ( exists $json -> meta -> { merged } )
           )
          { my $next = $json -> meta -> merged -> into_interval ;
            if ( $next )
              { $rec = $self -> events_since_ival ( $next ) ; }
            # else don't recurse ;
          }
        if ( ref $rec )
          { my $mark = $epoc ;
            $mark = $rec -> [ 0 ] -> epoch if @$rec ;
            my $new = [ grep { $_ -> epoch > $mark } @$events ] ;
            $res = RF -> merge ( $rec, $new ) ;
          }
        else
          { # an error occured in recursion ; return the error
            $res = $rec ;
          }
      }
    else
      { $res = "events_since_ival: missing in temp ($name)" ; }
    $res ;
  }

sub new_events
  { my $self = shift ;
    my $res = $self -> events_since_ival ( '1h' ) ;
    if ( ref $res )
      { my $ev  = @$res ;
        my $evn = grep { $_ -> type eq 'new' } @$res ;
        my $evd = $ev - $evn ;
        $self -> scores -> incr_ev  ( $ev ) ;
        $self -> scores -> incr_evn ( $evn ) ;
        $self -> scores -> incr_evd ( $evd ) ;
      }
    else
      { LOGx $res ; $res = [] ; }
    $res ;
  }

sub find_new_events
  { my $self = shift ;
    my $res = [] ;

    my $events = $self -> new_events ;
    if ( ref $events )
      { my $show =
          ( $self -> verbose
          ? $events
          : [ grep { $_ -> must_show } @$events ]
          ) ;
        LOGx $self -> show_events ( $show ) if @$show ;
        $res = $events ;
      }
    else
      { LOGx $events ; }
    $res ;
  }

sub show_events
  { my $self = shift ;
    my $list = shift ;
    my $res  = '' ;
    if ( @$list )
      { my $news = join "\n  ", map
          { my $have = $self -> in_locl ( $_ -> path ) ;
            my $del = 'del ' .
              ( $have
              ? ( -l $have
                ? 'lnk'
                : ( -d $have
                  ? 'dir'
                  : ( -f $have ? 'fil' : 'xxx' )
                  )
                )
              : 'dud'
              ) ;
            sprintf "%.5f %s %-7s %s"
              , $_ -> epoch
              , $_ -> ival
              , ( ( $_ -> type eq 'new' and $have )
                ? 'new upd'
                : ( ( $_ -> type eq 'delete' ) ? $del : $_ -> type )
                )
              , $_ -> path
              ;
          } reverse @$list ;

        $res = sprintf "---------------------------------------\n  %s", $news ;
      }
    $res ;
  }

sub Readdir
  { my $self = shift ;
    my $dir  = shift ;
    my $res = [] ;
    if ( opendir DIR, $dir )
      { $res = [ grep { ! /^\.\.?$/ } sort readdir DIR ] ; closedir DIR ; }
    $res ;
  }

sub Rm
  { my $self = shift ;
    my $fil  = shift ;
    print "rm $fil\n" if $self -> debug ;
    unlink $fil ;
  }

sub Rm_rf
  { my $self = shift ;
    my $obj  = shift ;
    print "rm-rf $obj\n" if $self -> debug ;
    if ( -l $obj or -f $obj )
      { $self -> Rm ( $obj ) ; }
    elsif ( -d $obj )
      { for my $fil ( map { "$obj/$_" ; } @{ $self -> Readdir ( $obj ) } )
          { $self -> Rm_rf ( $fil ) ; }
        rmdir $obj ;
      }
  }

sub get_batch
  { my $self   = shift ;
    my @eqs    = @_ ;
    my $conf   = $self -> conf ;
    my $local  = $conf -> local ;
    my @news   = () ;
    my %ev4pat = () ;
    my $events = RF -> merge ( @eqs ) ;
    my $todo   = [] ;
    my $xcrds  = [] ;
    my $addf   = 0 ;
    my $adds   = 0 ;
    my $delf   = 0 ;
    my $dels   = 0 ;

    # find the last event per path
    for my $event ( reverse @$events )
      { $ev4pat { $event -> path } = $event ; }

    for my $event ( values %ev4pat )
      { my $type = $event -> type ;
        my $path = $event -> path ;
        my $file = sprintf "%s/%s", $local, $path ;
        if ( $type eq 'new' )
          { if ( $self -> is_dir ( $file ) )
              { LOGx "get_batch : shouldn't happen : Rm_rf ($file)" ;
                $self -> Rm_rf ( $file ) ;
              }
            push @news, $event ;
          }
        elsif ( $type eq 'delete' )
          { $delf ++ ; $dels += $event -> score_del ;
            $self -> Rm_rf ( $file ) ;
          }
        else
          { LOGf "weird event type (%s) path (%s)", $type, $path ; }
      }

    $self -> get_remote ( [ map { $_ -> path } @news ] ) ;

# $event -> tries counts tries resulting in partial xfers
# ------------------
# xfer | done | todo
# ------------------
# ok   |    0 | -
# miss |    0 | incr tries ; push discard-candidates
# fail |    0 | push todo
# ok   |    1 | -
# miss |    1 | -
# fail |    1 | -

    for my $event ( @news )
      { my $path = $event -> path ;
        if ( $self -> sync -> is_ok or $event -> is_done )
          { $addf ++ ; $adds += $event -> score_add ; }
        elsif ( $self -> sync -> is_partial )
          { $event -> incr_tries ; push @$xcrds, $event ; }
        else
          { push @$todo, $event ; }
      }

    LOGf "%s ;\n  files add/replace [bytes] %d [%d] delete %d [%d]"
      , $self -> sync -> report, $addf, $adds, $delf, $dels
        if $self -> verbose ;

    for my $event ( @$xcrds )
      { my $path = $event -> path ;
        LOGf "todo %s - tries %s", $path, $event -> tries ;
        if ( $event -> tries < $MAX_TRIES )
          { push @$todo, $event ; }
        else
          { # fetch just this $path and discard
            # if sync is 'partial' and 'number of files: 0'
            my $type = $event -> type ;
            LOGf "$MAX_TRIES tries for %s ; discard?", $path ;
            $self -> get_remote ( [ $path ] ) ;
            my $epoc = $event -> epoch ;
            if ( $self -> sync -> is_ok )
              { LOGf "fetched %s %s %s", $type, $epoc, $path ;
                $addf ++ ; $adds += $event -> score_add ;
              }
            elsif ( $self -> sync -> is_partial_no_files )
              { LOGf "discard %s %s %s", $type, $epoc, $path ;
                $self -> scores -> incr_evxd ;
              }
            else
              { my $err = $self -> sync -> error ;
                LOGf "rsync returned (%s)" , ( $err || 'undef' ) ;
                LOGf "don't discard %s %s %s", $type, $epoc, $path ;
                push @$todo, $event ;
              }
          }
      }
    [ sort { $b -> epoch <=> $a -> epoch } @$todo ] ;
  }

package Blib::JSON::rfile::recent::event ;

eval Blib -> mk_methods ( qw(base ival tries ino) ) ;

my $SKIP_files =
  [ 'MIRRORED.BY'
  , 'MIRRORING.FROM'
  , 'SITES.html'
  , 'index.html'
  , 'indices/du-k.gz'
  , 'indices/find-ls.gz'
  , 'indices/ls-lR.gz'
  , 'indices/mirrors.json'
  , 'indices/timestamp.txt'
  , 'indices/cpan-stats.json'
  , 'misc/cpan-faq.html'
  , 'authors/02STAMP'
  , 'authors/00whois.html'
  , 'authors/00whois.xml'
  , 'modules/02STAMP'
  , 'modules/01modules.index.html'
  , 'modules/01modules.mtime.html'
  , 'modules/01modules.mtime.rss'
  , 'modules/02packages.details.txt'
  , 'modules/02packages.details.txt.gz'
  , 'modules/06perms.txt'
  , 'modules/06perms.txt.gz'
  , 'modules/07mirror.json'
  , 'modules/07mirror.yml'
  ] ;

my %SKIP = ( pats => [ '^(authors|modules)/RECENT' ] , fils => {} ) ;
for my $path ( @$SKIP_files ) { $SKIP { fils } { $path } ++ ; }

sub init
  { my $self = shift ;
    $self -> Blib::JSON::init ( @_ ) ;
    my $base = $self -> base ;
    my $efil = $base -> path ( 'local', $self -> path ) ;
    my $eino = $base -> ino ( $efil ) ;
    $self -> ino ( $eino ) ;
    $self -> tries ( 0 ) ;
    $self ;
  }

sub must_show
  { my $self = shift ;
    my $path = $self -> path ;
    return 0 if exists $SKIP { fils } { $path } ;
    for my $pat ( @{ $SKIP { pats } } )
      { return 0 if $path =~ /$pat/ ; }
    1 ;
  }

sub incr_tries
  { my $self  = shift ;
    my $tried = $self -> tries ;
    $self -> tries ( $tried + 1 ) ;
    $self -> tries ;
  }

sub is_done
  { my $self = shift ;
    my $base = $self -> base ;
    my $path = $self -> path ;
    my $file = $base -> path ( 'local', $path ) ;
    my $new  = ( lstat $file ) [ $INO ] ;
    my $old  = $self -> ino ;
    my $res  =
      ( defined $old
      ? ( defined $new and $new != $old )
      : ( defined $new )
      ) || 0 ;
    RF::LOGx "done $path" if $res and $base -> verbose ;
    $res ;
  }

sub score_add
  { my $self = shift ;
    my $base = $self -> base ;
    my $path = $self -> path ;
    my $file = $base -> path ( 'local', $path ) ;
    my $size = 0 ;
    if ( -l $file )
      { $base -> scores -> incr_fetl ; }
    elsif ( -f $file )
      { $size = -s $file ;
        $base -> scores -> incr_fetf ;
        $base -> scores -> incr_s_fil ( $size ) ;
        unless ( defined $self -> ino )
          { $base -> scores -> incr_fetn ;
            $base -> scores -> incr_s_new ( $size ) ;
          }
      }
    elsif ( ! -d $file )
      { RF::LOGf "*** can't score file/link ($file)" ; }
    RF::LOGf "score %8d %s", $size, $path if $base -> debug ;
    $size ;
  }

sub score_del
  { my $self = shift ;
    my $base = $self -> base ;
    my $file = $base -> path ( 'local', $self -> path ) ;
    my $size = 0 ;
    if ( -l $file )
      { $base -> scores -> incr_dell ; }
    elsif ( -f $file )
      { $size = -s $file ;
        $base -> scores -> incr_delf ;
        $base -> scores -> incr_s_del ( $size ) ;
      }
    elsif ( -d $file )
      { $base -> scores -> incr_deld ; }
    else
      { $base -> scores -> incr_ddud ; }
    $size ;
  }

##########################################################
package Blib::Mods ;

@Blib::Mods::ISA = qw(Blib) ;

sub print  { print  @_ ; }
sub printf { printf @_ ; }

##########################################################
package Blib::Mods::Conf ;

@Blib::Mods::Conf::ISA = qw(Blib) ;

our %CNF_defaults =
  ( remote              => 'cpan-rsync.perl.org::CPAN'
  , user                => ''
  , passwd              => ''
  , sleep_init_epoch    => '15m'
  , sleep_main_loop     => '1m'
  , full_sync_interval  => '0'
  , max_run_time        => '4w-15m'
  , model_file          => ''
  , prog_rsync          => '/usr/bin/rsync'
  , prog_iim            => $0
  , scoreboard_file     => ''
  , scoreboard_template => ''
  , allow_full_syncs    => '1'
  , hot_config          => '0'
  , loglevel            => 'terse'
  , iim_umask           => $UMASK
  , rotate              => { count => '8' , ival  => '4w' }
  , timeout             => '300s'
  ) ;

our @REQ_KEYS   = qw(local) ;

our $model = <<'MODEL' ;
{ "recent" :
     [ { "epoch" : "1307095198.77243"
       , "path"  : "authors/RECENT-1h.yaml"
       , "type"  : "new"
       }
     ]
, "meta" :
    { "aggregator" : [ "1h", "6h", "1d", "1W", "1M", "1Q", "1Y", "Z" ]
    , "protocol"   : 1
    , "interval"   : "1d"
    , "Producers"  :
        { "time" : 1307095198.80471
        , "$0" : "/home/mirror/perl5/bin/rrr-server"
        , "File::Rsync::Mirror::Recentfile" : "0.0.8"
        }
    , "filenameroot" : "RECENT"
    , "minmax" :
         { "mtime" : 1307091586
         , "min"   : "1307009184.4988"
         , "max"   : "1307095198.77243"
         }
    , "merged" :
        { "into_interval" : "1W"
        , "epoch" : "1307077006.35826"
        , "time"  : 1307077006.43983
        }
    , "dirtymark"         : "1300184987.04785"
    , "serializer_suffix" : ".json"
    }
}
MODEL

our %CNF_KEYS ;
for ( @REQ_KEYS, keys %CNF_defaults ) { $CNF_KEYS { $_ } ++ ; }
sub CNF_KEYS { sort keys %CNF_KEYS ; }
sub set_CNF_default
  { my $self = shift ;
    my $key = shift ;
    my $val = shift ;
    Carp::confess "set_CNF_default : bad key ($key)"
      unless exists $CNF_defaults { $key } ;
    $CNF_defaults { $key } = $val ;
  }

eval Blib -> mk_methods
  ( keys %CNF_KEYS, qw(parent _includes) ) ;

sub init
  { my $self = shift ;
    my %opts = ( @_ ) ;
    my $prnt = shift ;
    my $file = shift ;

    $self -> parent ( $opts { -parent } ) ;
    $self -> _includes ( [] ) ;
    my @keys = keys %CNF_defaults ;
    @{ $self } { @keys } = @CNF_defaults { @keys } ;

    my $err = $self -> get_conf ( $opts { -root } ) ;

    if ( $err )
      { $err ; }
    else
      { for my $key ( sort keys %CNF_KEYS )
          { $self -> $key ( $opts{$key} ) if defined $opts{$key} ; }
        $self -> errors or $self ;
      }
  }

sub default
  { my $self = shift ;
    my $opt  = shift ;
    die "default: nothing for $opt" unless exists $CNF_defaults { $opt } ;
    $CNF_defaults { $opt } ;
  }

sub temp  { my $self = shift ; sprintf '%s/%s', $self -> local, $CPAN_TEMP ; }
sub rtmp  { my $self = shift ; sprintf '%s/%s', $self -> temp, $RSYNC_TMP ; }
sub model { my $self = shift ; $model ; }
sub nap   { my $self = shift ; $SLEEP_NAP ; }

sub add_incl
  { my $self = shift ;
    my $file = shift ;
    my $stat = shift ;
    push @{ $self -> _includes }
      , Blib::Mods::Conf::Incl -> make ( $file, $stat ) ;
  }

sub includes
  { my $self = shift ;
    join ', ', map { $_ -> file ; } @{ $self -> _includes } ;
  }

sub root { my $self = shift ; $self -> _includes -> [ 0 ] -> file ; }

sub _split
  { my $str = shift ; map { $_ eq 'EMPTY' ? '' : $_ } split ' ', $str ; }

sub _fmt_vu
  { my $v = shift ;
    my $u = shift ;
    $v = sprintf "%.2f", $v if $v != int $v ;
    $v ? "$v $u" . ( $v == 1 ? '' : 's' ) : '' ;
  } ;

my $units =
  [ { nam => 'week'  , mod =>  0 }
  , { nam => 'day'   , mod =>  7 }
  , { nam => 'hour'  , mod => 24 }
  , { nam => 'minute', mod => 60 }
  , { nam => 'second', mod => 60 }
  ] ;

# init
  { my $siz = 1 ;
    my $mod = 1 ;
    my $nxt = undef ;
    for my $u ( reverse @$units )
      { $u -> { siz } = $siz *= $mod ;
        $u -> { nxt } = $nxt ;
        $mod = $u -> { mod } ;
        $nxt = $u ;
      }
  }

sub set_cnts ;
sub set_cnts
  { my $prec = shift ;
    my $unit = shift ;
    my $ival = shift ;
    my $nzs  = shift ;
    return 0 unless $unit ;
    my $res = 0 ;
    my $siz = $unit -> { siz } ;
    my $mod = $unit -> { mod } ;
    if ( $prec and $nzs == $prec and $ival )
      { $res = sprintf '%.2f', $ival / ( $mod * $siz ) ; }
    else
      { my $cnt = int ( $ival / $siz ) ;
        my $nz  = ( $cnt ? 1 : 0 ) ;
        $cnt += set_cnts
          ( $prec, $unit -> { nxt }, $ival % $siz, $nzs + $nz ) ;
        if ( $mod and $cnt == $mod )
          { $cnt = 0 ; $res = 1 ; }
        $unit -> { cnt } = $cnt ;
      }
    $res ;
  } ;

sub _text4secs
  { my $self = shift ;
    my $ival = shift ;
    my $prec = shift ; $prec = 4 unless defined $prec ;

    if ( 0.01 <= $ival and $ival < 60 )
      { sprintf "%.2f seconds", $ival ; }
    elsif ( $ival < 0 )
      { sprintf "-%.2f seconds", -$ival ; }
    else
      { for my $u ( @$units ) { $u -> { cnt } = 0 ; }
        $ival = int ( $ival + 0.5 ) ;
        set_cnts ( $prec, $units -> [ 0 ], $ival, 0 ) ;
        my $res = join ' ', map { _fmt_vu ( @{ $_ } { qw(cnt nam) } ) ; }
          grep { $_ -> { cnt } } @$units ;
        $res or '0 seconds' ;
      }
  }

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

sub _secs4spec
  { my $self = shift ;
    my $attr = shift ;
    my $spec = shift ;
    my $num  = '[-+]?\d+(\.\d)?' ;
    my $one  = "($num)?([smhdw]?)" ;
    my $all  = "^($one)+\$" ;
    my ( $res, $err ) ;

    unless ( $spec =~ /$all/ )
      { my $msg = '( [+-] NUM [smhdw] ) ...' ;
        $err = "bad spec ($spec) for '$attr' ; should be like '$msg'" ;
      }
    else
      { my $tmp = $spec ;
        $res = 0 ;
        while ( length $tmp )
          { die "500: '$tmp' ~! /^$one/" unless $tmp =~ /^$one/ ;
            my $num  = $1 ;
            my $unit = $3 ;
            $tmp = $' ;
            $res += s4uv $num, $unit ;
          }
      }
    $res, $err ;
  }

sub secs4spec
  { my $self = shift ;
    my $attr = shift ;
    $self -> _secs4spec ( $attr, $self -> $attr ) ;
  }

sub age4epoc
  { my $self = shift ;
    my $kind = shift ;
    my $epoc = shift ;
    sprintf "age %-6s : %s", $kind
      , $self -> _text4secs ( time - int ( $epoc ), 0 ) ;
  }

sub max_age_init
  { my $self = shift ;
    my $ival = $MAX_AGE_INIT ;
    my ( $res, $err ) = $self -> _secs4spec ( 'max_age_init', $ival ) ;
    if ( $err )
      { die "bad max_age_init '$ival' ($err)" ; }
    elsif ( ! $res )
      { die sprintf "default_full_sync_interval shouldn't be '%s'"
          , ( defined $res ? $res : '<undef>' ) ;
      }
    $res ;
  }

sub touched
  { my $self = shift ;
    my $res  = 0 ;
    for my $incl ( @{ $self -> _includes } )
      { my $mtim = ( stat $incl -> file ) [ $MTIME ] ;
        $res = 1 if $mtim > $incl -> mtime ;
      }
    $res ;
  }

sub get_conf
  { my $self = shift ;
    my $FILE = shift ;
    my $prnt = $self -> parent ;
    my $stat = [ stat $FILE ] ;
    my $err  = '' ;

    unless ( @$stat )
      { return "config : can't find config file '$FILE'\n" ; }
    elsif ( grep { $_ -> is_file ( $stat ) ; } @{ $self -> _includes } )
      { return "config error : '$FILE' is already included\n" ; }
    else
      { $self -> add_incl ( $FILE, $stat ) ; }

    open FILE, $FILE or return "config $FILE: can't open '$FILE' ($!)" ;
    my $CONF = join "\n", grep /./, <FILE> ;
    close FILE ;

    $CONF =~ s/\t/ /g ;           # replace tabs
    $CONF =~ s/^[+ ]+// ;         # delete leading space, plus
    $CONF =~ s/\n\n\s+/ /g ;      # glue continuation lines
    $CONF =~ s/\n\n\+\s+//g ;     # glue concatenation lines
    $CONF =~ s/\n\n\./\n/g ;      # glue concatenation lines

    chomp $CONF ;
    my $opt_d = $self -> debug ;
    Blib::_pr ( sprintf "----\n%s\n----\n", join "\n", split /\n\n/, $CONF )
      if $opt_d ;
    for ( grep ! /^#/, split /\n\n/, $CONF )
      { my ($key,$val) = split ' ', $_, 2 ;
        $val = '' unless defined $val ;
        $val = '' if $val eq 'EMPTY' ;
        Blib::_pr ( "conf '$FILE' : key '$key', val '$val'\n" ) if $opt_d ;
        if ( exists $CNF_KEYS { $key } )
          { $self -> $key ( $val ) ; }
        elsif ( $key eq 'temp' )
          { print "ingnoring keyword 'temp' (deprecated) in file $FILE\n"
               .  "- it is safe to remove the 'temp' line from $FILE\n"
               .  ( $val ? "- iim will not use directory $val\n" : '')
               ;
          }
        elsif ( $key eq 'include' )
          { unless ( $val )
              { $err .= "empty value for keyword '$key'" ; }
            else
              { $err .= $self -> get_conf ( $val ) ; }
          }
        elsif ( $key eq 'env' )
          { my ( $x, $y ) = split ' ' , $val ; $ENV { $x } = $y ; }
        else
          { $err .= "config error in $FILE : "
              . "unknown keyword '$key' value '$val'\n" ;
          }
      }
    $err ;
  }

sub errors
  { my $self = shift ;
    my $req  = '' ;
    my $err  = '' ;

    for my $key ( @REQ_KEYS )
      { $req .= "config error : missing required key '$key' ;\n"
          . "  -> use 'iim --$key ...' or configure '$key ...'\n"
          unless exists $self -> { $key } ;
      }

    for my $timspec
      ( qw(full_sync_interval sleep_init_epoch sleep_main_loop)
      , qw(max_run_time timeout)
      )
      { my ( $v, $r) = $self -> secs4spec ( $timspec ) ;
        if ( $r )
          { $err .= "config : $r\n" ; }
        else
          { $self -> $timspec ( $v ) ; }
      }

    { unless ( ref ( $self -> rotate ) )
        { my ( $cnt, $ivl ) = split ' ', $self -> rotate ;
          $cnt = $CNF_defaults { rotate } { count } unless defined $cnt ;
          $ivl = $CNF_defaults { rotate } { ival  } unless defined $ivl ;
          $self -> rotate ( { count => $cnt, ival => $ivl } ) ;
        }
      my $timspec = $self -> rotate -> { ival } ;
      my ( $v, $r) = $self -> _secs4spec ( 'rotate interval', $timspec ) ;
      if ( $r )
        { $err .= "config : $r\n" ; }
      else
        { $self -> rotate -> { ival } = $v ; }
      $v = $self -> rotate -> { count } ; ;
      $err .= sprintf "config error : rotate count is not a number ($v) ;\n"
        unless $v =~ /^[0-9]+$/ ;
    }

    for my $bool
      ( qw(allow_full_syncs hot_config) )
      { my $v = $self -> $bool ;
        $err .= "config error : bad value for $bool ($v) ; must be 0 or 1\n"
          unless $v =~ /^[01]$/ ;
      }

    { my $v = $self -> loglevel ;
      $err .= sprintf "config error : bad loglevel ($v) ; must be in (%s)\n"
        , ( join ', ', Blib -> _loglevels)
          unless Blib -> _is_loglevel ( $v ) ;
    }

    { my $v = $self -> iim_umask ;
      $err .= sprintf "config error : iim_umask not octal ($v) ;\n"
        unless $v =~ /^[0-7]+$/ ;
    }

    { $err .= sprintf "error : perl module Proc::Daemon is too old ; "
        . "install a recent version ; see the manual ;\n"
        unless Proc::Daemon -> can ( 'Status' )
           and Proc::Daemon -> can ( 'Init' ) ;
    }

    unless ( $req )
      { my $lcl = $self -> local ;
        my $tmp = $self -> temp  ;

        for my $pth ( $lcl, $tmp )
          { $err .= sprintf "config error : not a full path ($pth) ;\n"
              unless $pth =~ m!^/! ;
          }
        unless ( -d $lcl )
          { $err .= "can't find directory local ($lcl)\n" ; }
       }
    $req . $err ;
  }

sub show
  { my $self = shift ;
    my $sep  = shift || '' ;
    my $res  = "config :\n" ;
    for my $key ( sort keys %$self )
      { next if $key =~ m/^_/ ;
        next if $key eq 'parent' ;
        my $val = $self -> { $key } ;
        $val = '********' if $key eq 'passwd' ;
        $res .= sprintf "$key = '%s'\n", ( defined $val ? $val : '<undef>' ) ;
        if ( $val and ref $val eq 'ARRAY' and scalar @$val )
          { $res .= sprintf "  %s\n", join "\n  ", @$val ; }
        elsif ( ref $val eq 'HASH' and scalar keys %$val )
          { for my $k ( sort keys %$val )
              { $res .= sprintf "  %s = %s\n", $k, $val -> { $k } ; }
          }
      }
    $res .= sprintf "included '%s'\n", $self -> includes ;
    if ( $sep ) { chomp $res ; $res =~ s/\n/\n$sep/g ; }
    RF::LOGx $res ;
  }

sub unbless
  { my $self = shift ;
    my $res  = {} ;
    for my $key ( sort keys %$self )
      { next if $key =~ m/^_/ ;
        next if $key eq 'parent' ;
        next if $key eq 'user' ;
        next if $key eq 'passwd' ;
        my $val = $self -> { $key } ;
        if ( ref ( $val ) =~ /^(ARRAY|HASH)?$/ )
          { $res -> { $key } = $val ; }
      }
    $res -> { included } = $self -> includes ;
    $res ;
  }

##########################################################
package Blib::Mods::Conf::Incl ;

@Blib::Mods::Conf::Incl::ISA = qw(Blib) ;

eval Blib -> mk_methods ( qw(file stat) ) ;

sub mtime { my $self = shift ; $self -> stat -> [ $MTIME ] ; }
sub dev   { my $self = shift ; $self -> stat -> [ $DEV   ] ; }
sub ino   { my $self = shift ; $self -> stat -> [ $INO   ] ; }

sub is_file
  { my $self = shift ;
    my $stat = shift ;
    $self -> dev == $stat -> [ $DEV ] and
    $self -> ino == $stat -> [ $INO ] ;
  }

sub init
  { my $self = shift ;
    my $file = shift ;
    my $stat = shift ;
    $self -> file ( $file ) ;
    $self -> stat ( $stat ) ;
    $self ;
  }

##########################################################
package RF::Scores ;

@RF::Scores::ISA = qw(Blib) ;

use Time::HiRes qw(gettimeofday) ;
our $_T = gettimeofday ;

my @_counters =
  ( [ qw(loops loops)          ]
  , [ qw(ev    events)         ]
  , [ qw(evn   -> new)         ]
  , [ qw(evd   -> delete)      ]
  , [ qw(evxd  -> discarded)   ] # event axed
  , [ qw(rs    syncs)          ]
  , [ qw(rsf   -> failed )     ]
  , [ qw(frs   full syncs)     ]
  , [ qw(frsf  -> failed)      ]
  , [ qw(fetf  files fetched)  ]
  , [ qw(fetr  -> recents)     ]
  , [ qw(fetn  -> new files)   ]
  , [ qw(fetl  links fetched)  ]
  , [ qw(delf  files deleted)  ]
  , [ qw(dell  links deleted)  ]
  , [ qw(deld  dirs deleted)   ]
  , [ qw(ddud  dud deletes)    ]
  , [ qw(t_slp -> sleeping)    ]
  , [ qw(t_con -> connected)   ]
  , [ qw(t_frs -> full syncs)  ]
  , [ qw(t_out -> sync errors) ]
  , [ qw(s_rcvd sync received) ]
  , [ qw(s_rcvdr -> recents)   ]
  , [ qw(s_sent sync sent)     ]
  , [ qw(s_fil files fetched)  ]
  , [ qw(s_rct -> recents)     ]
  , [ qw(s_new -> new files)   ]
  , [ qw(s_del files deleted)  ]
  ) ;

my @counters = grep ! /^._/, map { $_ -> [ 0 ] ; } @_counters ;
my @timers   = grep   /^t_/, map { $_ -> [ 0 ] ; } @_counters ;
my @sizers   = grep   /^s_/, map { $_ -> [ 0 ] ; } @_counters ;
my @bandwds  = grep   /^x_/, map { $_ -> [ 0 ] ; } @_counters ;

my %name4cntr = () ;
for my $cntr ( @_counters )
  { my ( $key, @name ) = @$cntr ;
    $name4cntr { $key } = ( join ' ', @name ) || $key ;
  }
sub name4cntr { my $key = shift ; $name4cntr { $key } || $key ; }

eval Blib -> mk_methods
  ( qw(parent tmpl f_tmpl t_tmpl)
  , @counters, @timers, @sizers,  @bandwds
  ) ;
eval RF::Scores -> incr_methods ( @counters, @timers, @sizers, @bandwds ) ;

my $_TMPL ;
my $_TMPL_mtime = 0 ;

sub find_tmpl
  { my $self = shift ;
    my $tmpl = $self -> parent -> conf -> scoreboard_template || '' ;
    my $smpl = $self -> parent -> path ( 'temp', $SCB_SMPL ) ;
    my @tmpl = $tmpl ? ( $tmpl ) : ( $smpl ) ;
    my $file ;
    for my $cand ( @tmpl ) { if ( -f $cand ) { $file = $cand ; last ; } }
    unless ( $file )
      { RF::LOGf "can't find scoreboard template in (%s)", join ',', @tmpl ; }
    $file ;
  }

sub read_tmpl
  { my $self = shift ;
    my $file = shift ;
    my $res = '' ;
    if ( open TMPL, $file )
      { $res = join '', <TMPL> ; close TMPL ; }
    else
      { RF::LOGf "can't open scoreboard template '%s' (%s)", $file, $! ; }
    $res ;
  }

sub get_tmpl
  { my $self = shift ;
    my $file = $self -> find_tmpl ;
    my $mtim = $file ? ( RF -> mtime ( $file ) || 0 ) : 0 ;
    unless ( $file and $mtim )
      { $self -> tmpl ( '' ) ;
        $self -> f_tmpl ( '' ) ;
        $self -> t_tmpl ( 0 ) ;
      }
    elsif ( $file ne $self -> f_tmpl or $mtim != $self -> t_tmpl )
      { my $time = $self -> t_tmpl ;
        RF::LOGf "read scoreboard template :\n  file : %s\n  last read : %s"
          , $file
          , ( $time ? scalar localtime $time : 'never' )
          ;
        $self -> f_tmpl ( $file ) ;
        $self -> t_tmpl ( $mtim ) ;
        $self -> tmpl ( $self -> read_tmpl ( $file ) ) ;
      }
    $self -> tmpl ;
  }

sub init
  { my $self = shift ;
    my %opts = ( @_ ) ;
    $self -> parent ( $opts { parent } ) ;
    $self -> tmpl ( '' ) ;
    $self -> f_tmpl ( '' ) ;
    $self -> t_tmpl ( 0 ) ;
    for my $cntr ( @counters, @timers, @sizers, @bandwds )
      { $self -> $cntr ( 0 ) ; }
    $self ;
  }

sub _incr
  { my $self = shift ;
    my $attr = shift ;
    my $incr = shift ;
    $incr = 1 unless defined $incr ;
    $self -> $attr ( $incr + $self -> $attr ) ;
  }

sub incr_method
  { my $self = shift ;
    my $attr = shift ;
    my $meth = 'sub incr_%s { my $self = shift ; my $incr = shift ; '
      . '$self -> _incr ( %s, $incr ) ; }' ;
    sprintf $meth, $attr, "'$attr'" ;
  }

sub incr_methods
  { my $self = shift ; join '', map { $self -> incr_method ( $_ ) ; } @_ ; }

sub MB { sprintf "%.1f", $_ [ 0 ] / 1024 / 1024 ; }

sub _persec
  { my $tag  = shift ;
    my $size = shift ;
    my $time = shift ;
    my $bps  = 8 * $size / $time ;
    my $u ;
    my $r ;
    if ( $bps < 1024 )
      { $u = 'b/s'  ; $r = sprintf '%.2f', $bps ; }
    elsif ( $bps < 1024 * 1024 )
      { $u = 'Kb/s' ; $r = sprintf '%.2f', $bps / 1024 ; }
    else
      { $u = 'Mb/s' ; $r = sprintf '%.2f', $bps / 1024 / 1024 ; }
    "$tag [$u]", $r ;
  }

sub make_data
  { my $self = shift ;
    my $prnt = $self -> parent ;
    my $conf = $prnt -> conf ;
    my $mrt  = $conf -> max_run_time ;
    my $exit =
      ( $mrt ? $conf -> _text4secs ( $^T + $mrt - time ) : 'not scheduled' ) ;
    my $nxit = ( $mrt ? 'next exit' : 'exit' ) ;
    my $nfs =
      ( $prnt -> next_sync
      ?  $conf -> _text4secs ( $prnt -> next_sync - time )
      : 'not scheduled'
      ) ;
    my $nrot = $prnt -> next_rotate ;
    my $rot =
      ( $nrot
      ? ( ( $mrt and $nrot > $mrt )
        ? 'on next re-start'
        : $conf -> _text4secs ( $nrot - time )
        )
      : 'not scheduled'
      ) ;
    my $tag  = $prnt -> dtag ;
    my $mode = $prnt -> mode . ( $tag ? " -> $tag" : '' ) ;
    my $trun = ( gettimeofday - $_T ) || 1 ;
    my $busy = $trun ;
    my $prcs = 0 ;
    my $date = sprintf "%s UTC", scalar gmtime ;

    my $general =
      [ [ 'date'            => $date ]
      , [ 'host'            => ( $HOSTNAME || 'unknown' ) ]
      , [ 'version'         => $prnt -> version ]
      , [ 'pid &rarr; mode' => "$$ &rarr; $mode" ]
      , [ 'remote'          => $conf -> remote ]
      , [ 'status'          => $prnt -> status_html ]
      , [ 'age local'       => $prnt -> age ]
      , [ $nxit             => $exit ]
      , [ 'next full sync'  => $nfs  ]
      , [ 'next log rotate' => $rot  ]
      ] ;

    my $timers =
      [ [ 'run time' => $conf -> _text4secs ( $trun ) ]
      , ( map
            { my $time = $self -> $_
            ; my $_prc = 100 * $time / $trun
            ; my $perc = sprintf "%.2f %%", $_prc
            ; $busy -= $time
            ; $prcs += $_prc
            ; [ $_ => $conf -> _text4secs ( $self -> $_, 3 ) => $perc ]
            } @timers
        )
      , [ '-> busy'
        , $conf -> _text4secs ( $busy, 3 )
        , sprintf "%.2f %%", 100 - $prcs
        ]
      ] ;

    my $bndwids  =
      [ [ _persec 'sync in'  , $self -> s_rcvd, $trun ]
      , [ _persec 'sync out' , $self -> s_sent, $trun ]
      , [ _persec 'files in' , $self -> s_fil,  $trun ]
      ] ;

    my $counters = [ map { [ $_ =>    $self -> $_ ] ; } @counters ] ;
    my $sizers   = [ map { [ $_ => MB $self -> $_ ] ; } @sizers   ] ;

    if ( wantarray )
      { $general, $timers, $counters, $sizers, $bndwids ; }
    else
      { [ [ 'general'   , $general
          , 'timers'    , $timers
          ]
        , [ 'counters'  , $counters ]
        , [ 'data [MB]' , $sizers
          , 'bandwidth' , $bndwids
          ]
        ] ;
      }
  }

sub as_text
  { my $self = shift ;
    my $data = $self -> make_data ;
    my $list = [] ;
    my $W = 0 ;
    for my $col ( @$data )
      { while ( @$col )
          { my $tag = name4cntr shift @$col ;
            push @$list, [ $tag, '->' ] ;
            my $tups = shift @$col ;
            for my $tup ( @$tups )
              { my $name = name4cntr shift @$tup ;
                $W = length $name if $W < length $name ;
                push @$list, [ $name, join ' - ', @$tup ] ;
              }
          }
      }
    join ''
      , "--  scoreboard  ------------------------------\n"
      , ( map { sprintf "%-${W}s : %s\n", @$_ ; } @$list )
      , "----------------------------------------------\n"
      ;
  }

sub mk_trs
  { my $self = shift ;
    my $titl = shift ;
    my $itms = shift ;
    my $mcls = shift ;
    my @list = ( "<TH COLSPAN=$mcls class=title>$titl</TH>" ) ;
    for my $itm ( @$itms )
      { my $outs = 0 ;
        my $left = @$itm ;
        my $name = name4cntr shift @$itm ;
        $name =~ s/->/&rarr;/g ;
        push @list, join ''
          , "<TH class=left>$name</TH>"
          , ( map
                { $left --
                ; my $span = $mcls - $outs - $left
                ; my $cspn = $span == 1 ? '' : "COLSPAN=$span "
                ; my $attr = /^\d+(\.\d+)?(\s%)?$/ ? 'right' : 'left'
                ; $outs += $span
                ; s/->/&rarr;/g ;
                ; "<TD ${cspn}class=$attr>$_</TD>"
                } @$itm
            ) ;
      }
    [ @list ] ;
  }

sub _as_html
  { my $self = shift ;
    my $mrws = shift ;
    my @args = @_ ;
    my $mcls = 0 ;
    my @trs = () ;

    for my $arg ( @args )
      { if ( ref $arg )
          { for my $itm ( @$arg ) { $mcls = @$itm if @$itm > $mcls ; } }
      }

    while ( @args )
      { my $titl = shift @args ;
        my $itms = shift @args ;
        push @trs, @{ $self -> mk_trs ( $titl, $itms, $mcls ) } ;
      }

    if ( @trs < $mrws )
      { my $span = $mrws - @trs ;
        my $rspn = $span == 1 ? '' : "ROWSPAN=$span " ;
        push @trs, "<TD CLASS=fill ${rspn}COLSPAN=$mcls>&nbsp;</TD>" ;
      }

    [ @trs ] ;
  }


sub glue_by_row
  { my $self = shift ;
    my $cols = shift ;
    my $mrws = shift ;
    my $lens = 0 ;
    my @res = () ;
    map { $lens += @$_ ; } @$cols ;
    while ( $lens )
      { my @row = () ;
        for my $col ( @$cols )
          { if ( @$col ) { push @row, shift @$col ; $lens -- ; } }
        my $fill = @res == 0 ? "<th CLASS=fill ROWSPAN=$mrws></th>" : '' ;
        push @res, sprintf "<tr>%s</tr>\n" , join $fill , @row ;
      }
    join '', @res ;
  }

sub mk_tab
  { my $self = shift ;
    my $data = shift ;
    my $mrws = 0 ;
    for my $descr ( @$data )
      { my $cnt = 0 ;
        map { $cnt += ref $_ ? @$_ : 1 ; } @$descr ;
        $mrws = $cnt if $cnt > $mrws ;
      }
    sprintf "<table>\n%s</table>\n", $self -> glue_by_row
      ( [ map { $self -> _as_html ( $mrws, @$_ ) ; } @$data ] , $mrws ) ;
  }

sub as_html
  { my $self = shift ;
    my $prnt = $self -> parent ;
    my $conf = $prnt -> conf ;
    my $res  = 'Error ; see log' ;

    if ( my $TMPL = $self -> get_tmpl )
      { my $data = $self -> make_data ;
        my $tab  = $self -> mk_tab ( $data ) ;
        my $fmt = "<DIV CLASS=tab>%s</DIV>\n" ;
        my $ttxt = sprintf $fmt, $tab ;
        my $sml  = $conf -> sleep_main_loop ;
        my $refr = $sml + 15 ;
        my %subs =
          ( '%VERSION%' => $prnt -> version
          , '%REFRESH%' => $refr
          , '%SML%'     => $sml
          , '%DATE%'    => scalar ( localtime )
          , '%NEXT%'    => scalar ( localtime time + $refr )
          , '%TABLES%'  => $ttxt
          , '%SITE%'    => $IIM_SITE
          , '%LOGO%'    =>
              ( -f $prnt -> path ( 'temp', $IIM_LOGO )
              ? $IIM_LOGO
              : $IIM_LOGO_URL
              )
          ) ;
        for my $pat ( keys %subs )
          { my $sub = $subs { $pat } ; $TMPL =~ s/$pat/$sub/g ; }
        $res = $TMPL ;
      }
    $res ;
  }

sub _max { my $m = shift ; ( $m < $_ and $m = $_ ) for @_ ; $m ; }

sub as_php
  { my $self = shift ;
    my ( $gen, $tim, $cnt, $siz, $bws ) = $self -> make_data ;
    my $tab  = $self -> mk_tab
      ( [ [ 'general', $gen
          , 'timers' , $tim
          ]
        , [ 'counters'  , $cnt ]
        , [ 'data [MB]' , $siz
          , 'bandwidth' , $bws
          ]
        ]
      ) ;
    my $fmt = "<DIV CLASS=tab>%s</DIV>\n" ;
    my $ttxt = sprintf $fmt, $tab ;
    sprintf ''
      . "\$version      = '%s' ;\n"
      . "\$iim_scb_time = '%d' ;\n"
      . "\$iim_sleep_main_loop = %s ;\n"
      . "\$tab = <<<TAB\n%sTAB;\n"
      , $self -> parent -> version
      , time
      , $self -> parent -> conf -> sleep_main_loop
      , $ttxt
      ;
  }

sub as_json
  { my $self = shift ;
    my ( $gen, $tim, $cnt, $siz, $bws ) = $self -> make_data ;
    my $opts =
      [ [ 'sleep_main_loop' , $self -> parent -> conf -> sleep_main_loop ] ] ;
    my $meta =
      [ [ 'iim_scb_time', time ] ] ;
    for my $itm ( @$gen, @$tim, @$cnt, @$siz )
      { unshift @$itm, $itm -> [ 0 ] ;
        $itm -> [ 1 ] = name4cntr $itm -> [ 1 ] ;
      }
    my $res  =
      { general   => $gen
      , timers    => $tim
      , counters  => $cnt
      , sizes     => $siz
      , bandwidth => $bws
      , meta      => $meta
      , conf      => $self -> parent -> conf -> unbless
      , conf_def  => \%CNF_defaults
      } ;
    my $json = $LCL_JSON -> new -> utf8 ( 1 ) -> pretty -> encode ( $res ) ;
    $json .= "\n" unless $json =~ /\n$/ ;
    $json ;
  }

sub put_scoreboard
  { my $self = shift ;
    my $file = shift ;
    my $prnt = $self -> parent ;
    my $text ;

    if ( $file =~ /.html$/ )
      { $text = $self -> as_html ; }
    elsif ( $file =~ /.php$/ )
      { $text = $self -> as_php  ; }
    elsif ( $file =~ /.json$/ )
      { $text = $self -> as_json ; }
    else
      { $text = $self -> as_text ; }

    if ( $file and ! open FIL, ">$file" )
      { RF::LOGx "can't write scoreboard $file" ; }
    elsif ( $file )
      { RF::LOGx "write scoreboard $file" if $prnt -> debug ;
        print FIL $text ;
        close FIL ;
      }
    else
      { print $text ; }
  }

sub put_scoreboards
  { my $self = shift ;
    my $prnt = $self -> parent ;
    my $scbf = $prnt -> conf -> scoreboard_file ;
    my @fils = ( '' ) ;

    if ( $scbf )
      { @fils = split ' ', $scbf ; }
    else
      { @fils = ( $prnt -> path ( 'temp', $SCB_FILE ) ) ; }

    for my $file ( @fils )
      { $self -> put_scoreboard ( $file ) ; }
  }

##########################################################
package RF::Sync ;

@RF::Sync::ISA = qw(Blib) ;

eval Blib -> mk_methods
  ( qw(parent conn error cmd timer numf sent rcvd xfrd) ) ;

use Time::HiRes qw(gettimeofday) ;

sub reset
  { my $self = shift ;
    $self -> error ( undef ) ;
    $self -> numf ( undef ) ;
    $self -> sent ( undef ) ;
    $self -> rcvd ( undef ) ;
    $self -> xfrd ( undef ) ;
    $self -> cmd ( '' ) ;
    $self ;
  }

sub init
  { my $self = shift ;
    my %opts = ( @_ ) ;
    $self -> parent ( $opts { parent } ) ;
    $self -> reset ;
  }

sub _rep { map { defined $_ ? $_ : '<u>' } @_ ; }

sub request
  { my $self = shift ;
    my $fils = shift ;
    my $kind = shift || '' ;
    my $prnt = $self -> parent ;
    my $conf = $prnt -> conf ;
    $self -> reset ;

    my $user = $conf -> user ? $conf -> user . '@' : '' ;
    my @cmd  = ( $conf -> prog_rsync ) ;
    push @cmd, '-v' if $prnt -> debug ;
    push @cmd, @RSYNC_LIST ;
    push @cmd, '--timeout' => $conf -> timeout ;
    push @cmd, '--contimeout' => $conf -> timeout ;
    push @cmd, '--temp-dir' => $conf -> rtmp ;
    push @cmd, '--files-from' => $prnt -> req_file ;
    push @cmd, $user . $conf -> remote ;
    push @cmd, ( $kind eq 'r' ? $conf -> temp : $conf -> local ) ;
    my $cmd = $self -> cmd ( join ' ', @cmd ) ;

    if ( $prnt -> debug )
      { RF::LOGf "%s\n[ %s\n] %d\n"
          , $cmd
          , ( join "\n, ", @$fils )
          , scalar @$fils ;
      }
    $prnt -> put_req_file ( $fils ) ;

    my $pipe = new IO::Pipe ;
    my $time = gettimeofday ;
    my $conn = $self -> conn ( $pipe -> reader ( @cmd ) ) ;

    if ( $conn )
      { while ( defined ( my $line = $conn -> getline () ) )
          { my $x ;
            print $line if $prnt -> debug ;
            if ( $line =~ /total bytes sent:\s+(\d+)/i )
              { $x = $1 ; $self -> sent ( $x ) ; }
            elsif ( $line =~ /total bytes received:\s+(\d+)/i )
              { $x = $1 ; $self -> rcvd ( $x ) ; }
            elsif ( $line =~ /number of files:\s+(\d+)/i )
              { $x = $1 ; $self -> numf ( $x ) ; }
            elsif ( $line =~ /number of files transferred:\s+(\d+)/i )
              { $x = $1 ; $self -> xfrd ( $x ) ; }
          }
        $prnt -> scores -> incr_s_sent ( $self -> sent || 0 ) ;
        $prnt -> scores -> incr_s_rcvd ( $self -> rcvd || 0 ) ;
        if ( $kind eq 'r' )
          { $prnt -> scores -> incr_s_rcvdr ( $self -> rcvd || 0 ) ; }
        $self -> error ( $self -> close ) ;
        $self -> timer ( gettimeofday - $time ) ;
        RF::LOGf "sent %s, rcvd %s, xfrd %s, kind '%s' ok '%s'"
          , _rep ( $self -> sent, $self -> rcvd, $self -> xfrd )
          , $kind, $self -> is_ok
          if $prnt -> debug ;
      }
    else
      { $self -> error ( -1 ) ; }
    $self -> error ;
  }

sub close { my $self = shift ; $self -> conn -> close ; $? ; }

sub full
  { my $self = shift ;
    my $prnt = $self -> parent ;
    my $conf = $prnt -> conf ;
    $self -> reset ;

    my $user = $conf -> user ? $conf -> user . '@' : '' ;
    my @cmd =
      ( $conf -> prog_rsync
      , @RSYNC_FULL
      , '--timeout' => $conf -> timeout ()
      , '--contimeout' => $conf -> timeout ()
      , '--temp-dir' => $conf -> rtmp ()
      , $user . $conf -> remote
      , $conf -> local
      ) ;
    my $cmd = $self -> cmd ( join ' ', @cmd ) ;

    if ( $prnt -> debug ) { RF::LOGf "%s\n", $cmd ; }

    my $time = gettimeofday ;
    system @cmd ;
    $self -> error ( $? ) ;
    $self -> timer ( gettimeofday - $time ) ;
    $self -> error ;
  }

sub is_partial
  { my $self = shift ;
    my $err  = $self -> error ;
    my $sig  = ( $err & 127 ) ;
    my $xit  = ( $err >> 8  ) ;
    defined $err and $sig == 0 and ( $xit == $E_PRT or $xit = $E_MIS ) ;
  }

sub is_partial_no_files
  { my $self = shift ;
    my $numf = $self -> numf ;
    $self -> is_partial and defined $numf and $numf == 0 ;
  }

sub is_ok
  { my $self = shift ;
    my $err  = $self -> error ;
    defined $err and $err == 0 ;
  }

sub report
  { my $self = shift ;
    sprintf "files xferred %s, bytes sent %s received %s"
      , _rep $self -> xfrd, $self -> sent, $self -> rcvd ;
  }

1 ;
package main ;


BEGIN { Blib -> import () ; }
BEGIN { RF -> import () ; }

my $REMO = 'cpan-rsync.perl.org::CPAN' ;
my $TST  = 'testenv' ;

my $prog = substr($0,rindex($0,'/')+1) ;
my $Usage = <<USAGE ;
Usage: $prog [-v] [-q] [-d] [-c <conf>] [test-directory]
option v : be verbose
option q : be quiet
option d : show debug info
option f : clobber
option c : use config file <conf>
argument : the name of the (to-be-created) test-directory
           default : '$TST'
------------------------------------------------------
$prog : create a test environment for iim
-- it creates a test-directory with subdirs CPAN, sync
-- it creates a test iim.conf
-- it copies RECENT-*.json file from your real CPAN archive
   or it fetches them from $REMO
   if your archive is oldish
USAGE
sub Usage { die "$_[0]$Usage" ; }
sub Error { die "$prog: $_[0]\n" ; }
sub 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(v q d f c=s _conf) ) ;
Usage("Arg count\n") unless @ARGV <= 1 ;

$opt{v} ||= $opt{d} ;

$TST = shift if @ARGV ;
chop $TST if $TST =~ m!/$! ;
my $ABS = $TST ;
unless ( $ABS =~ m!^/! )
  { my $PWD = `pwd` ; chop $PWD ; $ABS = "$PWD/$ABS" ; }

Blib -> debug ( 0 ) ;

my $R    = RF -> make ( -root => $opt{c} ) ; # or die
my $conf = $R -> conf ;
my $root = $conf -> root ;
my @RFS  = @{ $R -> all_Recents } ;

sub mk_conf
  { my $dir = shift ;
    my $res = <<CONF ;
include $root
local $dir/CPAN
sleep_main_loop 15s
allow_full_syncs 0
CONF
    $res ;
  }

if ( $opt{_conf} )
  { my $conf = mk_conf 'testenv' ;
    chomp $conf ;
    printf "%s\n",  join "\n    ", split /\n/, $conf ;
    exit ;
  }

$R -> verbose ( $opt{v} ) ;
$R -> debug   ( $opt{d} ) ;

my $user = $conf -> user   ;
my $pswd = $conf -> passwd ;
my $locl = $conf -> local  ;
my $remo = $conf -> remote ;

Error "can't find your CPAN archive" unless -d $locl ;

Error "$TST already exists (as a file)" if -f $TST ;
my $opt = '-f' . ( $opt{c} ? " -c $opt{c}" : '' ) ;
Error <<ERR if -d $TST and not $opt{f} ;
directory $TST already exists ;
If it is ok to clobber it, use '-f' as in :

  perl $prog $opt $TST
ERR

Error "looking at your CPAN archive $locl ...\n"
  . "  -> can't find any good RECENT-*.json files"
    unless scalar grep { -f $_ ; } map { "$locl/$_" ; } @RFS ;
my $rf1h = $RFS [ 0 ] ;
my $file = $R -> in_locl ( $rf1h ) ; 
Error "looking at your CPAN archive $locl ...\n"
  . "  -> can't find $rf1h ; is your mirror up-to-date ?" unless $file ;
my $json = $R -> get_json ( $file ) ; 
my $time = int $json -> meta -> Producers -> time ;
my $age  = $^T - $time ;
Error "looking at your CPAN archive $locl ...\n"
  . "  -> your mirror appears to live in the future" if $age < 0 ;

my $old = Blib::Mods::Conf -> _text4secs ( $age ) ;

printf "$prog : your CPAN is in %s\n", $locl ;
printf "$prog : your CPAN is dated : %s\n", scalar localtime $time ; 
printf "$prog : your CPAN is %s old\n", $old ;
printf "$prog : your test CPAN is in %s\n", "$TST/CPAN/" ;

for my $dir ( $TST, "$TST/CPAN" )
  { -d $dir or mkdir $dir, 0755 or Error "can't mkdir $dir ($!)" ; }

unlink map { "$TST/CPAN/$_" ; } @RFS ;

if ( $age > 3 * 60 * 60 )
  { my $remo = $REMO ;
    my $rfs = join "\n      ", @RFS ;
    my $msg = <<MSG ;
$prog : looking at your CPAN archive $locl ...
  -> your CPAN is too old ; we will start with something more recent ;
  
    rsync from $remo into $TST/CPAN :

      $rfs

MSG
    print $msg ;
    my @cmd = 
      ( '|'
      , '/usr/bin/rsync'
      , '-av'
      , '--no-motd'
      , '--timeout'    => 60
      , '--contimeout' => 60
      , '--files-from' => '-'
      , $remo
      , "$TST/CPAN"
      ) ;
    my $cmd = join ' ', @cmd ;
    open CMD, $cmd or Error "fetching didn't work ; sorry" ;
    print CMD join "\n", @RFS ;
    close CMD ;
    my $all = 1 ;
    for my $rf ( @RFS )
      { unless ( -f "$TST/CPAN/$rf" )
          { printf "$prog : failed to get $rf\n" ; $all = 0 ; }
      }
    $all or Error "fetching didn't work ; sorry" ;
  }
else
  { my $cmd = "cp -a $locl/RECENT-*.json $TST/CPAN" ;
    printf "$prog : %s\n", $cmd ;
    system $cmd ; Error "can't do '$cmd' ($?)" if $? ;
  }

my $Conf = mk_conf $ABS ;
my $CONF = "$TST/iim.conf" ;
open CONF, ">$CONF" or Error "can't write $CONF ($!)" ;
print CONF $Conf ;
close CONF ;

my $sep = "######################" ;
printf "$prog : your test-config is :\n$sep\n%s$sep\n", $Conf ;

$sep = '---------------------------------------------------' ;
my $cmd = "perl -w iim -t -c $TST/iim.conf" ;
if ( -f 'iim' )
  { printf "$prog : running test ... : %s\n$sep\n", $cmd ;
    system $cmd ; Error "can't do '$cmd' ($?)" if $? ;
  }

print <<END ;
$sep
test the config : iim -c $TST/iim.conf -v -t
you can now run : iim -c $TST/iim.conf -v
or daemon mode  : iim -c $TST/iim.conf -v --daemon $TST
END