#! /usr/bin/perl -w

use strict ;
use Carp ;
use Blib ;
use lib::Tabs ;
use DBI ;
our $PRG = 'repocafe' ;
our $VER = '0.13.6' ;

$Carp::Verbose = 1 ;

our %TABLE_NAMES =
  ( repos  => 'repos'
  , paths  => 'repo_paths'
  , guests => 'repo_guests'
  , rights => 'repo_rights'
  , groups => 'repo_groups'
  , gr_mem => 'repo_group_members'
  , stats  => 'repo_stats'
  , tots   => 'repo_tots'
  , xusers => 'repo_xusers'
  , roots  => 'repo_roots'
  , mods   => 'repo_mods'
  ) ;

our $KW_LDAP = 'ldap' ; sub KW_LDAP { $KW_LDAP ; }
our $KW_CLAS = 'clas' ; sub KW_CLAS { $KW_CLAS ; }
our $KW_TREE = 'tree' ; sub KW_TREE { $KW_TREE ; }
our $KW_BIND = 'bind' ; sub KW_BIND { $KW_BIND ; }
our $KW_ATTR = 'attr' ; sub KW_ATTR { $KW_ATTR ; }
our $SECRET  = 'jlsadywr4n8sdydf8wery' ; sub SECRET { $SECRET ; }
our $Repocafe ;

sub Version { "$PRG version $VER" ; }
sub version { "$PRG-$VER" ; }
sub TABLE_NAMES { %TABLE_NAMES ; }
sub Repocafe { $Repocafe ; }

sub make_cafe
  { my %opts =
     ( c => undef
     , d => 0
     , q => 0
     , v => 0
     , -conn => 1
     , @_
     ) ;
    my $cafe = Blib::Dbs -> new ( 'Repocafe' ) ;
    $cafe -> set_opts ( %opts ) ;
    $Repocafe = ref $cafe ;
#   printf "1 Cafe debug %s\n", $cafe -> debug ;
#   printf "1 Blib debug %s\n", Blib  -> debug ;
#   printf "1 cafe debug %s\n", $cafe -> debug_me ( 'd' ) ;
#   printf "1 Conf debug %s\n", Blib::Mods::Conf -> debug ;
    if ( Blib -> debug and ! $cafe -> debug_me )
      { Blib::Mods -> debug ( 2 ) ; }
    else
      { Blib::Mods -> debug ( $cafe -> debug ) ; }
    Blib::Mods::Conf -> verbose ( $cafe -> verbose ) ;
    $cafe -> init ( $opts { c }, ! $opts { -conn } ) ;
    $cafe ;
  }

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

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

package Blib::Dbs::Repocafe ; ######################################

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

sub init
  { my $self = shift ;
    my $path = shift ;
    my $_noc = shift ;
    Blib::Dbs::init ( $self ) ;
    $self -> conf ( $self -> get_config ( $path ) ) ;
    $self -> define_tables ;
    Blib::Rec::Repocafe::guests -> add_ISA ( 'Blib::Mods::User' ) ;
    $self -> db_connect unless $_noc ;
    $self ;
  }

sub dbh { my $self = shift ; $self -> _dbh ; }

sub db_connect_as
  { my $self = shift ;
    my $conf = $self -> conf ;
    my $user = shift || $conf -> db_user ;
    my $pswd = shift || $conf -> db_pswd ;
    my $db_host = $conf -> db_host ;
    my $db_name = $conf -> db_name ;
    printf "db connect : host %s, db %s, user %s\n",
      $db_host, $db_name, $user if $self -> verbose ;
    my $dbh = DBI ->
      connect
        ( "dbi:Pg:dbname=$db_name;host=$db_host", $user, $pswd
        , { RaiseError => 1, AutoCommit => 1 }
        ) or die $DBI::errstr ;
    $self -> _dbh ( $dbh ) ;
  }

sub db_connect
  { my $self = shift ;
    my $conf = $self -> conf ;
    $self -> db_connect_as ( $conf -> db_user, $conf -> db_pswd ) ;
  }

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

sub find_config
  { my $self = shift ;
    my $arg = shift ;
    my @LIST = $arg ? ( $arg ) : $self -> config_list ;
    for my $conf ( @LIST ) { return $conf if -f $conf ; }
    die sprintf "can't find a config file :\n  %s\n" , join "\n  ", @LIST ;
  }

sub get_config
  { my $self = shift ;
    my $path = shift ;
    my $file = $self -> find_config ( $path ) ; # or die
    Blib::Mods::Conf -> make ( $self, $file ) ;
  }

sub lookups
  { my $self = shift ;
    my $uids = {} ; for ( @_ ) { $uids -> { $_ } ++ ; }
    my $res  = [] ;
    for my $uclas ( @{ $self -> conf -> clas_list } )
      { last unless scalar keys %$uids ;
        for my $user ( @{ $uclas -> lookups ( keys %$uids ) } )
          { push @$res, $user ; delete $uids -> { $user -> login } ; }
      }
    $res ;
  }

sub lookup
  { my $self = shift ;
    my $uid  = shift ;
    my $users = [] ;
    for my $uclas ( @{ $self -> conf -> clas_list } )
      { $users = $uclas -> lookups ( $uid ) ; last if @$users ; }
    ( @$users ) ? shift @$users : undef ;
  }


sub usage
  { my $self = shift ;
    my $prog = shift ;
    my $dir  = $self -> conf -> dir_admin ;
    my $cmd  = "cd $dir ; perl $prog -help |" ;
    open CMD, $cmd or die "can't popen '$cmd' ($!)" ;
    <CMD> ;
  }

sub revision
  { my $self = shift ;
    my $conf = $self -> conf ;
    my $CMD = "svn info -r head" ;
    open CMD, "$CMD|" or return undef ;
    my $res ;
    while ( <CMD> ) { if ( /Revision: (\d+)/ ) { $res = $1 ; } }
    close CMD ;
    $res ;
  }

sub check_tabs
  { my $self = shift ;
    my $rep = {} ;
    my $res = 1 ;
    $rep -> { miss } = [] ;
    $rep -> { bads } = [] ;
    for my $tab ( @{ $self -> _tabs } )
      { unless ( $rep -> { $tab } { have } = $tab -> _in_db )
          { $res = 0 ; next ; }
        my $tnam = $tab -> _name ;
        $rep -> { $tab } { fkis } = [] ;
        $rep -> { $tab } { refs } = [] ;
        my $fkis = $tab -> _foreign_key_info || [] ;
        $rep -> { $tab } { fkis } = $fkis ;
        my $have = {} ;
        for my $fki ( @$fkis )
          { my $p = $fki -> { ptxt } ;
            my $f = $fki -> { ftxt } ;
            push @{ $rep -> { $tab } { refs } }, [ $p, $f ] ;
            $rep -> { fkis } { $p } { $f } = $fki ;
            $have -> { $p } = $f ; 
          }

        for my $col ( @{ $tab -> _cols } )
          { unless ( $rep -> { $col } { have } = $col -> _in_db )
              { $res = 0 ; next ; }
            next unless my $fkey = $col -> _fkey ;
            next unless $rep -> { $fkey } { have } ;
            my $cnam = $col  -> _name ; 
            my $ftab = $fkey -> _tabl ;
            my $p = "$tnam.$cnam" ;
            my $f = join '.', map { $_ -> _name } $ftab, $fkey ;
            push @{ $rep -> { $col } { fkey } { have } }, [ $p, $f ] ;
            unless ( exists $have -> { $p } )
              { push @{ $rep -> { $col } { fkey } { miss } }, [ $p, $f ] ;
                push @{ $rep -> { miss } }, [ $p, $f ] ;
                $res = 0 ;
              }
            else
              { my $h = $have -> { $p } ;
                if ( $f ne $h )
                  { push @{ $rep -> { $col } { fkey } { bads } }
                      , [ $p, $f, $h ] ;
                    push @{ $rep -> { bads } }, [ $p, $f, $h ] ;
                    $res = 0 ;
                  }
              }
          }
      }
    $rep -> { res } = $res ;
    $rep ;
  }

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

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

our %CNF_defaults =
  ( db_pref           => ''
  , db_owner          => ''
  , db_opswd          => ''
  , file_access       => 'svnaccessfile'
  , file_guests       => 'guestusers'
  , file_log          => 'repocafe_log'
  , cmd_perl          => '/usr/bin/perl'
  , cmd_svnadmin      => '/usr/bin/svnadmin'
  , cmd_svnlook       => '/usr/bin/svnlook'
  , cmd_commit_email  => '/usr/bin/perl commit-email.pl'
  , top_head          => ''
  , aux_head          => ''
  , top_body          => ''
  , aux_body          => ''
  , top_rules_usage   => ''
  , aux_rules_usage   => ''
  , top_statistics    => ''
  , aux_statistics    => ''
  , create_guests     => ''
  , has_groups        => 1
  , viewvc            => 1
  , motd              => ''
  , mail_from_admin   => ''
  , mail_from_noreply => ''
  , www_scheme        => 'https'
  , $KW_LDAP => {}
  , $KW_BIND => {}
  , $KW_ATTR => {}
  , $KW_CLAS => []
  , $KW_TREE => {}
  ) ;

our @REQ_KEYS =
  qw(organisation dir_admin dir_data dir_www
     www_user www_group www_server www_contact www_secret
     db_host db_name db_user db_pswd admin_user admin_group
    ) ;

our %CNF_KEYS ;
for ( @REQ_KEYS, keys %CNF_defaults ) { $CNF_KEYS { $_ } ++ ; }

eval Blib -> mk_methods
  ( keys %CNF_KEYS, qw(root cafe ldaps clases clas_list trees) ) ;

sub init
  { my $self = shift ;
    my $cafe = shift ;
    my $file = shift ;

    $self -> cafe ( $cafe ) ;
    $self -> root ( $file ) ;
    my @keys = keys %CNF_defaults ;
    @{ $self } { @keys } = @CNF_defaults { @keys } ;
    $self -> get_conf () ;
    $self ;
  }

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

sub get_conf
  { my $self = shift ;
    my $FILE = ( @_ ? shift : $self -> root ) ;
    my $cafe = $self -> cafe ;
    my $err  = '' ;

    if ( grep $_ eq $FILE,  @{ $self -> {_include} } )
      { die "already included : '$FILE'" ; }
    else
      { push @{ $self -> {_include} }, $FILE ; }

    open FILE, $FILE or die "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 ;
    print "--$CONF--\n" if $opt_d ;
    for ( grep ! /^#/, split /\n\n/, $CONF )
      { my ($key,$val) = split ' ', $_, 2 ;
        $val = '' unless defined $val ;
        $val = '' if $val eq 'EMPTY' ;
        print "conf '$FILE' : key '$key', val '$val'\n" if $opt_d ;
        if ( exists $CNF_KEYS { $key } )
          { my $ref = exists $self -> { $key } && ref ( $self -> $key ) ;
            if ( $ref and $ref eq 'ARRAY' )
              { push @{ $self -> $key }, [ _split $val ] ; }
            elsif ( $ref and $ref eq 'HASH' )
              { my ( $k, @v ) = _split $val ;
                if ( defined $k )
                  { $self -> $key -> { $k } = [ @v ] ; }
                else
                  { $err .= "- config '$key' (HASH) : value is missing\n" ; }
              }
            else
              { $self -> $key ( $val ) ; }
          }
        elsif ( $key eq 'show' )
          { $self -> show_conf if $cafe -> verbose ; }
        elsif ( $key eq 'no_viewvc' )
          { $self -> viewvc ( 0 ) ; }
        elsif ( $key eq 'no_groups' )
          { $self -> has_groups ( 0 ) ; }
        elsif ( $key eq 'exit' )
          { die 'exit per config directive' ; }
        elsif ( $key eq 'include' )
          { $self -> get_conf ( $val ) ; }
        elsif ( $key eq 'env' )
          { my ( $x, $y ) = split ' ' , $val ;
            $ENV { $x } = $y ;
            printf "config : setenv '%s'\n   '%s'\n", $x, $y
              if $self -> verbose ;
          }
        else
          { $self -> show_conf ;
            die "unknown keyword '$key' (value '$val')\n" ;
          }
      }

    my $ldaps = {} ;
    for my $tag ( keys %{ $self -> { $KW_LDAP } } )
      { my $row = $self -> ldap -> { $tag } ;
        my $cnt = @$row ;
        $err .= "- wrong number of fields ($cnt) for ldap $tag\n"
          unless 2 <= $cnt and $cnt <= 3 ;
        my $val =
          { tag  => $tag
          , serv => $row -> [ 0 ]
          , base => $row -> [ 1 ]
          , dscr => ( $row -> [ 2 ] || $tag )
          } ;
        $val -> { dscr } =~ s/_/ /g ;
        my $ldap = Blib::Mods::Ldap -> new ;
        $ldaps -> { $tag } = $ldap -> init ( $val ) ;
      }

    for my $tag ( keys %{ $self -> { $KW_BIND } } )
      { my $row = $self -> bind -> { $tag } ;
        my $cnt = @$row ;
        $err .= "- wrong number of fields ($cnt) for bind $tag\n"
          unless $cnt == 2 ;
        my $dn = $row -> [ 0 ] ;
        my $pw = $row -> [ 1 ] ;
        unless ( exists $ldaps -> { $tag } )
          { $err .= "- bind : ldap ($tag) not found\n" ; }
        else
          { my $ldap = $ldaps -> { $tag } ;
            $ldap -> binddn ( $dn ) ;
            $ldap -> bindpw ( $pw ) ;
          }
      }

    for my $tag ( keys %{ $self -> { $KW_ATTR } } )
      { my $row = $self -> attr -> { $tag } ;
        my $cnt = @$row ;
        $err .= "- wrong number of fields ($cnt) for bind $tag\n"
          unless $cnt == 3 ;
        my $login = $row -> [ 0 ] ;
        my $uname = $row -> [ 1 ] ;
        my $email = $row -> [ 2 ] ;
        unless ( exists $ldaps -> { $tag } )
          { $err .= "- attr : ldap ($tag) not found\n" ; }
        else
          { my $ldap = $ldaps -> { $tag } ;
            $ldap -> login ( $login ) ;
            $ldap -> uname ( $uname ) ;
            $ldap -> email ( $email ) ;
          }
      }
    $self -> ldaps ( $ldaps ) ;

    my @clas_list = () ;
    for my $row ( @{ $self -> { $KW_CLAS } } )
      { my $val = {} ;
        my $clas = $row -> [ 0 ] ;
        my $uclas ;
        if ( $row -> [ 1 ] eq 'table' )
          { my $cnt = @$row ;
            $err .= "- clas ($clas) : wrong number of fields ($cnt)\n"
              unless 6 <= $cnt and $cnt <= 7 ;
            $val =
              { clas  => $row -> [ 0 ]
              , typ   => $row -> [ 1 ]
              , table => $row -> [ 2 ]
              , login => $row -> [ 3 ]
              , paswd => $row -> [ 4 ]
              , cname => $row -> [ 5 ]
              , dscr  => $row -> [ 6 ]
              } ;
            $uclas = 'Blib::Mods::Clas::Table' ;
          }
        elsif ( $row -> [ 1 ] eq 'ldap' )
          { my $cnt = @$row ;
            my $tag = $row -> [ 2 ] ;
            my $pat = $row -> [ 3 ] ;
            $err .= "- clas ($clas) : wrong number of fields ($cnt)\n"
              unless 4 <= $cnt and $cnt <= 5 ;
            $err .= "- clas ($clas) : ldap ($tag) not found\n"
              unless exists $ldaps -> { $tag } ;
            $err .= "- clas ($clas) : pattern ($pat) must be lowercase-only"
              unless $pat eq lc $pat ;
            $val =
              { clas => $row -> [ 0 ]
              , typ  => $row -> [ 1 ]
              , tag  => $row -> [ 2 ]
              , pat  => $row -> [ 3 ]
              , dscr => $row -> [ 4 ]
              , ldap => $ldaps -> { $tag }
              } ;
            $uclas = 'Blib::Mods::Clas::Ldap' ;
          }
        $val -> { dscr } ||= $clas ;
        $val -> { dscr } =~ s/_/ /g ;
        $val -> { cafe } = $cafe ;
        push @clas_list, $uclas -> make ( $val ) ;
      }
    $self -> clas_list ( [ @clas_list ] ) ;
    my $clases = {} ;
    for my $uclas ( @clas_list )
      { $clases -> { $uclas -> clas } = $uclas ; }
    $self -> clases ( $clases ) ;

    my $trees = $self -> { $KW_TREE } ;
    for my $path ( keys %$trees )
      { my $row = $trees -> { $path } ;
        my @creas = split /,/, ( $row -> [ 1 ] || '' ) ;
        for my $crea ( sort @creas )
          { $err .= "- tree ($path) : clas ($crea) not found\n"
              unless exists $clases -> { $crea } ;
          }
        my $val =
          { pref => $row -> [ 0 ]
          , crea => [ @creas ]
          } ;
        $trees -> { $path } = $val ;
      }

    my $create_guests = $self -> create_guests ;
    my $new_crg = {} ;
    for my $clas ( split ' ', $create_guests )
      { $new_crg -> { $clas } ++ ; }
    $self -> create_guests ( $new_crg ) ;

    $self -> { mail_from_admin    } ||= $self -> { www_contact } ;
    $self -> { mail_from_noreply  } ||=
      sprintf '%s@%s', 'svn-no-reply'
        , ( $self -> { www_server } || 'no-host' ) ;

### checks

    my $tag = 'config error' ;
    for my $key ( @REQ_KEYS )
      { $err .= "- missing config for '$key'\n" 
          unless exists $self -> { $key } ;
      }

{   my $key = $KW_CLAS ;
    if ( exists $self -> { $key } and 0 == @{ $self -> { $key } } )
      { $err .= "- no valid config line(s) for '$key'\n" }
    $key = $KW_TREE ;
    if ( exists $self -> { $key } and 0 == keys %{ $self -> { $key } } )
      { $err .= "- no valid config line(s) for '$key'\n" }
    my $secret = $self -> www_secret ;
    if ( $secret =~ /^\*+$/  or $secret eq $SECRET )
      { $err .= "- bad www_secret '$secret' ; pick an other one\n" ; }
    elsif ( length $secret < 16 )
      { $err .= "- www_secret '$secret' too short (< 16 chars)\n" ; }
}

    for my $clas ( sort keys %{ $self -> { create_guests } } )
      { $err .= "- create_guests : clas ($clas) not found\n"
          unless exists $clases -> { $clas } ;
      }

    my $pref = $self -> db_pref ;
    $err .= "- database prefix ($pref) should be all lowercase\n"
      if $pref ne lc $pref ;
    $err .= "- database prefix ($pref) should be alpha-numeric\n"
      if $pref and $pref !~ /^[a-z]\w*$/ ;
    
    my $schm = $self -> www_scheme ;
    $err .= "- www_scheme must be 'http' or 'https'\n"
      unless $schm =~ /^https?$/ ;
    
    die sprintf "config errors in root: %s\n%s\n", $self -> root, $err if $err ;
    $self ;
  }

sub show_conf
  { my $self = shift ;
    print "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n" ;
    for my $key ( sort keys %$self )
      { next if $key =~ m/^_/ ;
        my $val = $self -> { $key } ;
        print "$key = '$val'\n" ;
        if ( ref $val eq 'ARRAY' and scalar @$val )
          { printf "  %s\n", join "\n  ", @$val ; }
        elsif ( ref $val eq 'HASH' and scalar keys %$val )
          { for my $k ( sort keys %$val )
              { printf "  %s = %s\n", $k, $val -> { $k } ; }
          }
      }
    printf "included '%s'\n"
      , join "', '", @{ $self -> {_include} } ;
    print "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n" ;
  }

sub dir_repos { my $self = shift ; $self -> dir_data . '/repos' ; }

package Blib::Tab::Repocafe ; ##########################################

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

sub init
  { my $self = shift ;
    my %opts = @_ ;
    Blib::Tab::init ( $self, %opts ) ;
    $self -> _cafe ( $opts { -cafe } ) ;
    $self ;
  }

package Blib::Rec::Repocafe ; ##########################################

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

sub init
  { my $self = shift ;
    my $hash = shift ;
    Blib::Rec::init ( $self, $hash ) ;
    $self -> _cafe ( $self -> _tabl -> _cafe ) ;
    $self ;
  }

###################################################################
package Blib::Rec::Repocafe::repos ;

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

sub init
  { my $self = shift ;
    my $hash = shift ;
    Blib::Rec::Repocafe::init ( $self, $hash ) ;
    my $rid = $self -> id ;
    $self -> paths
      ( $self -> _cafe -> paths -> select_hash
         ( 'path', -where => "rid = $rid" )
      ) ;
    $self ;
  }

sub repo_name
  { my $self = shift ;
    my $ownr = $self -> ownr ;
    my $side = $self -> side ;
    my $name = $self -> name ;

    my $conf = $self -> _tabl -> _cafe -> conf ;
    my $pref = $conf -> tree -> { $side } { pref } ;
    $pref .= ( $pref ? '.' : '' ) . '%n' ;
    $pref =~ s/%p/$side/g ;
    $pref =~ s/%o/$ownr/g ;
    $pref =~ s/%n/$name/g ;
    $pref ;
  }

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

sub revision
  { my $self = shift ;
    my $path = $self -> path ;
    my $conf = $self -> _cafe -> conf ;
    my $prg  = $conf -> cmd_svnlook ;
    my $CMD = "$prg youngest $path" ;
    open CMD, "$CMD|" or return undef ;
    my $res = <CMD> ;
    close CMD ;
    chomp $res ;
    $res ;
  }

sub size
  { my $self = shift ;
    my $path = $self -> path ;
    my $CMD = "/usr/bin/du -sk $path" ;
    open CMD, "$CMD|" or return undef ;
    my $res = ( split ' ', <CMD> ) [ 0 ] ;
    close CMD ;
    $res ;
  }

sub watchers ()
  { my $self = shift ;
    my $cafe = $self -> _tabl -> _cafe ;
    my $pths = $self -> paths ;
    my @res  = () ;
    my @pids = () ;

    for my $Path ( sort values %$pths )
      { my $path = $Path -> path ;
        my $rrs  = $Path -> rights ;
        for my $rr ( values %$rrs )
          { push @pids, $rr -> pid if $rr -> wat ; }

      }
    my $res = $cafe -> lookups ( @pids ) ;
    map { $_ -> email } @$res ;
  }

sub watch_list ()
  { my $self = shift ;
    my $cafe = $self -> _tabl -> _cafe ;
    my $pths = $self -> paths ;
    my $res  = {} ;
    my %pids = () ;

    for my $Path ( sort values %$pths )
      { my $path = $Path -> path ;
        my $rrs  = $Path -> rights ;
        for my $rr ( values %$rrs )
          { if ( my $user = $cafe -> lookup ( $rr -> pid ) )
              { my $mail = $user -> email ;
                $res -> { $mail } = {} unless exists $res -> { $mail } ;
                $res -> { $mail } { $path } =  $rr -> wat ;
              }
          }
      }
    $res ;
  }

###################################################################
package Blib::Rec::Repocafe::paths ;

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

sub init
  { my $self = shift ;
    my $hash = shift ;
    Blib::Rec::Repocafe::init ( $self, $hash ) ;
    my $rid = $self -> id ;
    $self -> rights
      ( $self -> _cafe -> rights -> select_hash
         ( 'pid', -where => "rid = $rid" )
      ) ;
    $self ;
  }

package Blib::Tab::Repocafe::stats ; #####################################

sub get_upd_stats
  { my $self = shift ;
    my $then = shift ;
    my $res = {} ;
    my $sub = $self -> _make_sql
      ( -fields => "rid, max(time) AS time"
      , -where  => "time > ?"
      , -group  => 'rid'
      , -having => 'count (*) > 1'
      ) ;

    for my $rec
      ( $self -> select
          ( -where => "( rid, time ) IN ( $sub )"
          , -order => "rid, time"
          , -args  => [ $then ]
          )
      )
      { $res -> { $rec -> rid } = $rec ; }
    $res ;
  }

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

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

eval Blib -> mk_methods ( qw(login email name clas) ) ;

sub init
  { my $self = shift ;
    my $hash = shift ;
    Carp::croak "init_user : bad args (@_)" if @_ ;
    $self -> login ( $hash -> { login } ) ;
    $self -> email ( $hash -> { email } ) ;
    $self -> name  ( $hash -> { name  } ) ;
    $self -> clas  ( $hash -> { clas  } ) ;
    $self ;
  }

package Blib::Rec::Repocafe::guests ; #####################################

# ISA Blib::Mods::User ; see Blib::Dbs::Repocafe -> init ;

sub init
  { my $self = shift ;
    my $hash = shift ;
    Blib::Rec::Repocafe::init ( $self, $hash ) ;
    $self -> clas ( 'guests' ) ;
    $self ;
  }

package Blib::Tab::Repocafe::guests ; #####################################

sub lookups
  { my $self = shift ;
    my @uids = @_ ;
    my $res  = [] ;

    my $guests = $self -> select_hash ( 'login' ) ;
    for my $uid ( sort @uids )
      { print "trying uid ($uid) as guest ...\n"
          if $self -> _cafe -> debug ;
        if ( exists $guests -> { $uid } )
          { push @$res, $guests -> { $uid } ;
            print "  found uid ($uid) as guest ...\n"
              if $self -> _cafe -> debug ;
          }
      }
    $res ;
  }

### class methods ##########################################

sub file_out
  { use DB_File ;

    my $self = shift ;
    my $out  = shift ;
    my $txt  = "$out.txt" ;
    my $db   = "$out.db" ;
    my $tmp  = "$txt.$$" ;
    my $tdb  = "$db.$$" ;
    my %tmp ;

    my @guests = $self -> select ;

    tie %tmp , "DB_File" , $tdb , O_RDWR|O_CREAT , 0644 , $DB_HASH
      or die "can't tie" ;
    open TMP, ">$tmp" or die "can't write $tmp ($!)" ;
    for my $guest ( sort { $a -> login cmp $b -> login } @guests )
      { $tmp { $guest -> login } = $guest -> passwd ;
        printf TMP "%s:%s\n" , $guest -> login , $guest -> passwd ;
      }
    untie %tmp ;
    close TMP ;
    rename $tmp, $txt or die "can't rename $tmp, $txt ($!)" ;
    rename $tdb, $db  or die "can't rename $tdb, $db  ($!)" ;
  }

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

use Net::LDAP ;

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

eval Blib -> mk_methods
  ( qw(tag serv base dscr binddn bindpw login uname email) ) ;

sub init
  { my $self = shift ;
    my $rec  = shift ;
    my $serv = $rec -> { serv } ;

    $self -> tag  ( $rec -> { tag  } ) ;
    $self -> serv ( $rec -> { serv } ) ;
    $self -> base ( $rec -> { base } ) ;
    $self -> dscr ( $rec -> { dscr } ) ;
    $self -> binddn ( '' ) ;
    $self -> bindpw ( '' ) ;
    $self -> login  ( 'uid'  ) ;
    $self -> uname  ( 'cn'   ) ;
    $self -> email  ( 'mail' ) ;

    $self ;
  }

sub test_bind
  { my $self = shift ;
    my $serv = $self -> serv ;
    my $dn   = $self -> binddn ;
    my $pw   = $self -> bindpw ;
    my $res  = "can bind to $serv" ;

    my $ldap = Net::LDAP -> new ( $serv )
      or Carp::croak "can't make Net::LDAP ($serv)" ;
    my $mesg = $pw ? $ldap -> bind ( $dn, password => $pw ) : $ldap -> bind ;
    my $errr = $mesg -> error ;
    if ( $mesg -> code )
      { $res = "can't bind to $serv ($errr)\n  dn '$dn'\n  pw '$pw'" ; }
    else
      { $ldap -> unbind ; }
    $res ;
  }

sub lookups
  { my $self = shift ;
    my $clas = shift ;
    my $pat  = shift ;
    my @uids = @_ ;
    my $res  = [] ;

    my $serv  = $self -> serv ;
    my $base  = $self -> base ;
    my $dn    = $self -> binddn ;
    my $pw    = $self -> bindpw ;
    my $login = $self -> login ;
    my $uname = $self -> uname ;
    my $email = $self -> email ;

    my $ldap = Net::LDAP -> new ( $serv )
      or Carp::croak "can't make Net::LDAP ($serv)" ;
    my $mesg = $pw ? $ldap -> bind ( $dn, password => $pw ) : $ldap -> bind ;
    my $errr = $mesg -> error ;
    die "can't bind to $serv ($errr)" if $mesg -> code ;

    for my $uid ( sort @uids )
      { print "trying uid ($uid) on serv $serv pat ($pat) ...\n"
          if $self -> debug ;

        $mesg = $ldap -> search
          ( base   => $base
          , filter => "$login=$uid"
          , attrs  => [ $uname, $email ]
          ) ;
        next if $mesg -> code ;
        for my $entry ( $mesg -> entries )
          { my $dn = lc $entry -> dn ;
            if ( $dn =~ /$pat/i )
              { my $cn   = $entry -> get_value ( $uname ) ;
                my $mail = $entry -> get_value ( $email ) ;
                my $user = Blib::Mods::User -> make
                  ( { login => $uid
                    , email => $mail
                    , name  => $cn
                    , clas  => $clas
                    }
                  ) ;
                push @$res, $user ;
                print "  found uid ($uid) pat ($pat) ...\n"
                  if $self -> debug ;
                last ;
              }
          }
      }
    $ldap -> unbind () ;
    $res ;
  }

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

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

eval Blib -> mk_methods ( qw(clas typ dscr cafe) ) ;

sub init
  { my $self = shift ;
    my $rec  = shift ;
    $self -> clas ( $rec -> { clas } ) ;
    $self -> typ  ( $rec -> { typ  } ) ;
    $self -> dscr ( $rec -> { dscr } ) ;
    $self -> cafe ( $rec -> { cafe } ) ;
    $self ;
  }

package Blib::Mods::Clas::Table ; ####################################

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

eval Blib -> mk_methods ( qw(table login paswd cname) ) ;

sub init
  { my $self = shift ;
    my $rec  = shift ;
    Blib::Mods::Clas::init ( $self, $rec ) ;
    $self -> table ( $rec -> { table } ) ;
    $self -> login ( $rec -> { login } ) ;
    $self -> paswd ( $rec -> { paswd } ) ;
    $self -> cname ( $rec -> { cname } ) ;
    $self ;
  }

sub lookups
  { my $self = shift ;
    my @uids = @_ ;
    $self -> cafe -> guests -> lookups ( @uids ) ;
  }

package Blib::Mods::Clas::Ldap ; #####################################

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

eval Blib -> mk_methods ( qw(tag pat ldap) ) ;

sub init
  { my $self = shift ;
    my $rec  = shift ;
    Blib::Mods::Clas::init ( $self, $rec ) ;
    $self -> tag  ( $rec -> { tag  } ) ;
    $self -> pat  ( $rec -> { pat  } ) ;
    $self -> ldap ( $rec -> { ldap } ) ;
    $self ;
  }

sub lookups
  { my $self = shift ;
    my @uids = @_ ;
    $self -> ldap -> lookups ( $self -> clas, $self -> pat, @uids ) ;
  }

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

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

eval Blib -> mk_methods ( qw(prog synop opts olst args pars) ) ;

sub init
  { my $self  = shift ;
    my $prog  = shift ;
    my @usage = @_ ;
    my $usage = join '', @usage ;
    chop @usage ;
    my $opts  = {} ;
    my $olst  = [] ;
    my $args  = [] ;
    my $pars  = [] ;
    %{ $self } =
      ( prog  => $prog
      , synop => ''
      , opts  => $opts
      , olst  => $olst
      , args  => $args
      , pars  => $pars
      ) ;
    my $line = shift @usage ;
    die "no 'Usage:-line' ($usage)" unless $line =~ /^Usage: (.*)$/ ;
    $self -> synop ( $1 ) ;
    my $state = 'opt' ;
    my $opt = '' ;
    for $line ( @usage )
      { if ( $state eq 'opt' )
          { if ( $line =~ /^------/ )
              { $state = 'descr' ; }
            elsif ( $line =~ /^option\s+(\S+)\s+:\s+(.*)/ )
              { $opt = $1 ;
                $opts -> { $opt } = $2 ;
                push @$olst, $opt ;
              }
            elsif ( $line =~ /^\s+(.*)/ )
              { $opts -> { $opt } .= ' ' . $1 ; }
            elsif ( $line =~ /^argument(s?)\s+(.*)\s+:\s+(.*)/ )
              { push @$args, { arg => $2, txt => $3 } ; }
          }
        elsif ( $state eq 'descr' )
          { if ( $line =~ /^------/ )
              { $state = 'fin' ; }
            elsif ( $line =~ /^-\s+(.*)$/ )
              { my $par = $1 ;
                my $prog = $self -> prog ;
                $par = ucfirst $par if @$pars and $par =~ /^$prog/ ;
                push @$pars, $par ;
              }
            elsif ( $line =~ /^(\s+)(\S.*)/ )
              { my $sep = $1 ;
                my $txt = $2 ;
                if ( length $sep > 2 )
                  { $pars -> [ @$pars - 1 ] .= "\n\n $txt\n\n" ; }
                else
                  { $pars -> [ @$pars - 1 ] .= ' ' 
                      unless $pars -> [ @$pars - 1 ] =~ /\n$/ ;
                    $pars -> [ @$pars - 1 ] .= $txt ;
                  }
              }
          }
      }
    $self -> dmp if $self -> debug ;
    $self ;
  }

sub as_pod
  { my $self  = shift ;
    my $auth  = shift ;
    my $synop = $self -> synop ;
    my $name  = $self -> pars -> [ 0 ] ;
    my $descr = '' ;
    my $opts  = '' ;

    my @pars = @{ $self -> pars } ;
    shift @pars ;
    for my $par ( @pars )
      { $descr .= sprintf "%s\n\n", $par ; }

    unless ( @{ $self -> olst } )
      { $opts = 'none' ; }
    else
      { $opts = "=over 4\n\n" ;
        for my $key ( @{ $self -> olst } )
          { my $opt = "B<-$key>" ;
            if ( $synop =~ /\[-$key\s+([^\]]+)\]/ )
              { $opt = "B<-$key> I<$1>" ; }
            else
              { $opt = "B<-$key>" ; }
            my $txt = $self -> opts -> { $key } ;
            $txt =~ s/(\<[^>]*\>)/I$1/g ;
            $opts .= sprintf "=item %s\n\n%s\n\n" , $opt, $txt ;
          }
        my @args = @{ $self -> args } ;
        for my $arg ( @args )
          { my $txt = $arg -> { txt } ;
            $txt =~ s/(\<[^>]*\>)/I$1/g ;
            $opts .= sprintf "=item B<%s>\n\n%s\n\n"
              , $arg -> { arg }, $txt ;
          }
        $opts .= "=back\n\n" ;
      }

  <<POD ;
=pod

=head1 NAME

$name

=head1 SYNOPSIS

=begin html

<pre>$synop</pre>

=end html

=begin man

$synop

=end man

=head1 DESCRIPTION

$descr

=head1 OPTIONS

$opts

=head1 AUTHOR

$auth

=cut
POD

  }

sub pod_author
  { my $self = shift ;
    my $vers = shift ;
    my $rev  = shift ;
    my $date = shift ;
    my $copy = '2010' ;
    my $year = ( gmtime ) [ 5 ] + 1900 ;
    $copy .= " - $year" unless $copy eq $year ;
    <<AUTH

=begin html

  <blockquote>
  <p>
  &copy; $copy
  <a href="http://idefix.net/">Koos van den Hout</a>
  -
  <a href="http://www.staff.science.uu.nl/~penni101/">Henk P. Penning</a>
  <br/>
  <a href="http://www.science.uu.nl/ICTbeta/">ICT-&beta;</a>,
  <a href="http://www.science.uu.nl/">Faculty of Science</a>,
  <a href="http://www.uu.nl/">Utrecht University</a>
  <br/>
  $vers - $date - revision $rev
  </p>
  </blockquote>
  <hr/>
  <p>
  <a href="http://validator.w3.org/check?uri=referer"><img
  src="http://www.w3.org/Icons/valid-xhtml10" style="border-width:0"
  alt="Valid XHTML 1.0 Strict" height="31" width="88" /></a>
  &nbsp;
  <a href="http://jigsaw.w3.org/css-validator/check/referer">
  <img style="border:0;width:88px;height:31px" alt="Valid CSS!"
  src="http://jigsaw.w3.org/css-validator/images/vcss"/></a>
  </p>

=end html

=begin man

  (c) $copy Koos van den Hout -- Henk P. Penning
  k.vandenhout\@uu.nl -- http://idefix.net/
  penning\@uu.nl -- http://www.staff.science.uu.nl/~penni101/
  ICT-beta, Faculty of Science, Utrecht University
  $vers - $date - revision $rev

=end man

=begin text

  (c) $copy
  Koos van den Hout -- k.vandenhout\@uu.nl
  -- http://idefix.net/
  Henk P. Penning -- penning\@uu.nl
  -- http://www.staff.science.uu.nl/~penni101/
  ICT-beta, Faculty of Science, Utrecht University
  $vers - $date - revision $rev

=end text

AUTH
  }

1 ;