# -*- Coding: utf-8; srcfile://; mode: perl -*-

package FFII::Knecht;
use A2E::db;
# copyleft (GNU GPL 2.0 or later) 2003 by Hartmut Pilch <phm@ffii.org>
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(rows2text);
use POSIX;
use Locale::gettext;
setlocale(LC_MESSAGES, ""); 
textdomain("knecht");
# use strict;
# use utf8; # unstabil, erzeugt seltsame Fehler bei Verwendung von HTML::Template
# use Data::Dumper;

our $Error = 0;
# my $UTF8 = $] >= 5.008 ? 1 : 0;
my $UTF8 = 0;
my %LOGLEVELS = ( off => 0, min => 1, sign => 1, norm => 2, verb => 3, noiz => 4, debug => 5, max => 5 ) ; 
my $ADMPWX = 'm73Xr0WW1HNAQ' ;

open SAVOUT, ">&STDOUT";
open SAVERR, ">&STDERR";
open SAVIN, "<&STDIN";

sub filesize {
    my $file = shift;
    return unless -r $file;
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat($file);
    return $size;
}

sub zor { # like '||' but regards anything that is defined as true.
    return unless @_;
    my $car = shift;
    return $car if defined $car;
    return zor(@_);
}

sub ctl2esc {
    my $line = shift;
    $line =~ s/\n/\\n/g;
    $line =~ s/\t/\\t/g;
    return $line;
}

sub lindex {
    my ($match, $i, @list) = @_;
    return -1 unless @list;
    my ($car, @cdr) = @list;
    return $i if $car =~ /^$match$/;
    lindex($match, ++$i, @cdr);
}

sub nodups {
    my($car, @cdr);
    return unless @_;
    $car = shift;
    @cdr = @_;
    return $car, nodups(grep !/^$car$/, @cdr);
}

sub esc2ctl {
    my $line = shift;
    $line =~ s/\\n/\n/g;
    $line =~ s/\\t/\t/g;
    return $line;
}

sub parentdir {
    my $node = shift;
    return unless $node;
    my ($par, $sub) = $node =~ m(\A(.*)/([^/]+)\Z);
    return $par;
}
sub fmkdir {
    my $node = shift;
    return unless $node;
    return $node if -d $node;
    if (fmkdir(parentdir($node))) { mkdir $node;return $node; };
}
sub ensure_writable {
    my $node = shift;
    return unless $node;
    return if -d $node;
    return $node if -w $node;
    return $node if fmkdir(parentdir($node));  
}
# sub log10 { my $n = shift;return log($n)/log(10); }

sub vjoin {
    my ($sep, @args) = @_;
    return '' unless @_;
    local $_;
    return join $sep, map { if (defined $_) { "$_" } else { '' } } @args;
}

sub gjoin {
    my ($sep, @args) = @_;
    return '' unless @_;
    local $_;
    return vjoin $sep, grep { defined $_ } @args;
}

sub commed {
    return vjoin ", ", grep { defined $_ } @_;
}
sub colcommed {
    my (@args) = @_;
    local $_;
    return vjoin ", ", map { if (length($_) > 0) { "$_" } else { "?" } } @args;
}
sub enclosed { my ($s, $l, $r) = @_;return $l . $s . ($r || $l); };
sub squoted { my $s = shift;$s =~ s/\'/\\\'/g;return enclosed($s, "'"); }
sub sqcommed {
    my @args = @_;
    local $_;
    return commed map { squoted($_) } grep { defined $_ } @args;
}
sub tabbed {
    return vjoin "\t", grep { defined $_ } @_;
}
sub coltabbed {
    my @args = @_;local $_;
    return vjoin "\t", map { if (length ($_) > 0) { $_ } else { "?" } } @args;
}
sub lined {
    return vjoin "\n", grep { defined $_ } @_;
}
sub dlined {
    return vjoin "\n\n", grep { defined $_ } @_;
}
sub spaced {
    return vjoin " ", grep { defined $_ } @_;
}
sub slashed {
    return vjoin "/", grep { defined $_ } @_;
}
sub dirslashed {
    return vjoin "/", grep { defined $_ } @_;
}
sub untabbed {
    return split "\t", shift;
}
sub undirslashed {
    return split "/", shift;
}
sub rows2text {
    return lined map { coltabbed(@{$_}) } @_;
}

sub trimquotes {
    my $str = shift;
    while (1) { last unless ($str =~ s/\A\s*[\"\'](.*)\"\s*\Z/$1/) or ($str =~ s/\A\s*\'(.*)\'\s*\Z/$1/); }
    return $str;
}

sub min {
    my ($n1, $n2) = @_;
    return $n1 > $n2 ? $n2 : $n1;
}

sub dirtimestamp { 
    my $dir = shift;verdir $dir;
    my $str = shift || "%04d-%02d-%02d %02d:%02d:%02d";
    return sprintf($str, 2000+$dir->{dies}{jar}%100, $dir->{dies}{mon}, $dir->{dies}{mdi}, $dir->{dies}{hor}, $dir->{dies}{min}, $dir->{dies}{sek}); 
}
sub dirdatestamp { 
    my $dir = shift;verdir $dir;
    my $str = shift || "%04d-%02d-%02d";
    return sprintf($str, 2000+$dir->{dies}{jar}%100, $dir->{dies}{mon}, $dir->{dies}{mdi});
}

binmode STDIN, ":utf8" if $UTF8;

sub bellecho { 
    my ($dir, $bell, $str, @args) = @_;
    $str = sprintf("$str", @args) if @args;
    do { print FLOG "$str\n";print STDERR "$str\n" } if $dir->bell($bell); 
};
sub vecho { my($dir, $str, @args) = @_;bellecho($dir, 'verb', $str, @args); }
sub decho { my($dir, $str, @args) = @_;bellecho($dir, 'debug', $str, @args); }

sub ok { my ($dir, $res) = @_;return $res or $dir->lasterror == 0; }
sub aua { 
    my ($dir, $err, $str, @args) = @_;
    $str = sprintf($str, @args) if @args;
    printf STDERR "%s\n$str\n", gettext("Aua!") unless $dir->bell('quiet');
    $dir->decho("$err");
    $dir->{err} = $err;
    $Error = $err;
    return; };

sub verdb {
    my ($dir, $dbname) = @_;
    $dbname = $dbname || 'ffii';
    return $dir->{pgdb}{$dbname} if $dir->{pgdb}{$dbname};
    my ($debug, $verbose) = ($dir->bell('debug'), $dir->bell('verbose'));
    $dir->{pgdb}{$dbname} = A2E::db->new($dbname, debug=>$debug, verbose=>$verbose);
    return $dir->{pgdb}{$dbname};
};

sub verobj { my $obj = shift;ref $obj or do { $Error = 195;printf STDERR "%s\n%s\n", gettext("Aua!"), gettext("Ungueltiges Patent-Verzeichnis-Objekt.");return };return $obj; }
sub verusr { my $usr = shift;ref $usr or do { $Error = 194;printf STDERR "%s\n%s\n", gettext("Aua!"), gettext("Ungueltiges Nutzer-Objekt.");return };my $dir = verdir($usr->{dir}) or return;return $usr, $dir; }
sub verdir { my $dir = shift;ref $dir or do { $Error = 193;printf STDERR "%s\n%s\n", gettext("Aua!"), gettext("Ungueltiges Verzeichnis-Objekt.");return };$Error = 0;$dir->{err} = 0;return $dir; }
sub vertab {
    my $dir = shift;verdir $dir or return;
    my $tab = shift;
    return $dir->aua(48, gettext("Tabellenname fehlt")) unless $tab;
    return $dir->aua(47, gettext("undefinierte Tabelle %s"), $tab) unless $dir->{vdefs}{$tab};
    return $dir->aua(46, gettext("unzureichend definierte Tabelle %s"), $tab) unless $dir->{vdefs}{$tab}{lkeys} and $dir->{vdefs}{$tab}{rkeys};
    return $tab;
}

sub lasterror { my $dir = shift;$dir->decho("LASTERROR %d", $dir->{err});return $dir->{err} || $Error; };

my $TMPDIR = "/tmp";
my $FGPG = dirslashed $TMPDIR, "knecht$$.gpg";
my $FTMP = dirslashed $TMPDIR, "knecht$$.txt";
my $FLOG = dirslashed $TMPDIR, "knecht$$.log";
my %AUTHBELLS = ( PW=>'passwds', ID=>'users', DE=>'from', AP=>'admpass', VB=>'verbose', CS=>'cs', DB=>'debug', UM=>'umask', EU=>'ExekUmask', NS=>'nosql', PF=>'profil', TO=>'txtonly', RO=>'rdbonly', LL=>'log', LC=>'locale', DN=>'dbname', DH=>'dbhost', DP=>'dbport' );

sub UMask {
    my ($dir, $bell) = @_;
    local $_ = $dir->bell($bell);
    return unless /^\d$/;
    umask oct($_);
}

sub direxit { 
    my $dir = shift;
    if ($dir->bell('gpg')) { close STDIN;open STDIN, "<&SAVIN";unlink $FTMP if -r $FTMP and not $dir->bell('debug') };
    $dir->vecho(uc($dir->{err} ? gettext("am Ende") : gettext("Erledigt")));
    $dir->vecho($dir->{err} ? "KO" : "OK");
    close FLOG;
    exit($dir->bell('mail') ? 0 : $dir->{err}); 
};

sub exek { 
    my $dir = verdir(shift) or return;
    my $str = shift;
    $str = sprintf($str, @_) if @_;
    my $loud = $dir->bell('debug');
    do { open STDERR, ">/dev/null";open STDOUT, ">/dev/null"; }  unless $loud;
    $ENV{PATH} = '/bin:/usr/bin:/usr/local/bin';
    $ENV{IFS} = '';
    $ENV{CDPATH} = '';
    $ENV{ENV} = '/etc/bash.bashrc';
    $ENV{BASH_ENV} = '';
    $ENV{TERM} = 'dumb';
    $dir->decho("exek $str");
    $dir->UMask('ExekUmask');
    my $res = system($str);
    $dir->UMask('umask');
    do { open STDERR, ">&SAVERR";open STDOUT, ">&SAVOUT"; } unless $loud;
    $dir->decho("exek result: %d", $res);
    my $ok = $res == 0;
    $dir->vecho($ok ? gettext("Befehl\n  %s\nerfolgreich ausgefuehrt.") : gettext("Befehl\n  %s\nerfolglos ausgefuehrt."), $str);
    return $ok;
}

sub exekaua { 
    my($dir, $err, $str, @args) = @_;    
    $str = sprintf($str, @args) if @args;
    my $ok = $dir->exek($str);
    if ($ok) { return 1 } else { return $dir->aua($err, gettext("KO")) } 
};

sub knechtusage { return sprintf("s.\n\n%s\n\n", "http://www.ffii.org/verein/knecht/") };

my %BELLS = ( umask=>'7', ExekUmask=>'2', log=>$LOGLEVELS{norm}, profil=>'profil', vdefs=>'verbdefs', coding=>'utf-8', verb=>0, debug=>0, locale=>'en_US', dbname=>'ffii' );

sub bell {
    my ($dir, $var) = @_;
    my $val = $dir->{bell}{$var};
    return $val if defined $val;
    $val = $BELLS{$var};
    return $val if defined $val;
}

sub bellkv {
    my ($dir, @bells) = @_;
    $dir->decho("BELLKV @bells"); 
    my ($key, $val);
    while (@bells) { 
	$key = shift @bells;
	$val = shift @bells;
	next unless $key and defined $val and length($val) > 0;
	$dir->{bell}{$key} = $val;
    }
    return 1;
};

sub setbells {
    my ($dir, $str, @bells) = @_;
    $dir->decho("SETBELLS str $str bells @bells");
    my @tups = ();
    @tups = map { split /\s*[:=]\s*/ } split(/,\s*/, $str) if $str;
    push @bells, @tups;
    $dir->decho("SETBELLS bells @bells\n"); 
    $dir->bellkv(@bells);
    $dir->decho("BELLS: keys %s; values %s", commed(keys %{$dir->{bell}}), commed(values %{$dir->{bell}}));
    $UTF8 = ($UTF8 and not $dir->bell('bytechar')); 
    return 1;
}

sub readpermsfromfiles {
    my ($usr, $dir, $fperm, $fi, $fo, $line, $key, $val, @keys);
    ($usr, $dir) = verusr(shift) or return;
    $dir->decho("READPERMSFROMFILES");
    $fperm = $dir->{perm} || dirslashed($dir->{frmbas}, "perm.txt");
    return $dir->aua(41, gettext("Erlaubnisse unklar")) unless -r $fperm;
    foreach $fi ($fperm, dirslashed($usr->{udir}, ".perm"))
    { if (-r $fi and open FI, "<", $fi) {
	$dir->decho("\tfile $fi");
	while ($line = <FI>) { 
	    ($key, $val) = $line =~ /^\s*(\S+)\s*\t\s*(\S+)\s*$/;
	    if ($key) { 
		$usr->{perm}{$key} = $val;
		$dir->decho("\t\tperm of %s is %s.", $key, $usr->{perm}{$key}); 
	    }; };
	close FI; } };
    return 1;
}

sub readpermsfromdabas {
    my ($usr, $dir) = verusr(shift) or return;
    $dir->decho("READPERMSFROMDABAS");
    return unless $dir->verdb;
    my @records = $dir->{pgdb}{ffii}->get_records('perm', { permuid=>$usr->{uid} }, qw(permvar permval));
    foreach $record (@records) {
	($tem, $val) = @$record;
	$usr->{perm}{$tem} = $val;
    };
    return 1;
};
sub writepermstofile {
    my ($usr, $dir) = verusr(shift) or return;
    $dir->decho("WRITEPERMSTOFILE");
    my $fo = dirslashed($usr->{udir}, ".perm");
    open FO, ">", $fo or return $dir->aua(57, gettext("kann Datei %s nicht schreiben"), $fo);
    local $_;for (keys %{$usr->{perm}}) { printf FO tabbed($_, $usr->{perm}{$_}); };
    close FO;
    return 1;
}

sub setperms {
    my ($usr, $dir, $fperm, $fi, $fo);
    ($usr, $dir) = verusr(shift) or return;
    $dir->decho("SETPERMS");
    $usr->readpermsfromfiles;
    $usr->readpermsfromdabas;
    # $usr->writepermstofile; # BUG: writes perm.txt stuff to ~uid/.perm
    return 1;
}

sub perm {
    my ($usr, $dir) = verusr(shift) or return;
    return $usr->{perm}{join(":", @_)};
}
sub permkv {
    my ($usr, $dir) = verusr(shift) or return;
    my ($key, $val);
    while (1) { $key = shift;last unless $key;$val = shift;next unless defined $val;$dir->{perm}{$key} = $val };
    return 1;
}

sub authinput {
    my ($usr, $dir);
    ($usr, $dir) = verusr(shift) or return;
    local $_;
    if ($dir->bell('gpg'))
    {
	$dir->decho("versuche authentifizierte Eingabe: $TMPDIR, $FGPG, $FTMP");
	open FG, ">$FGPG" or return $dir->aua(117, gettext("kann nicht in %s schreiben", $FGPG));
	while (<STDIN>) { print FG $_; }
	close FG;
	system("gpg", "--homedir", "/home/apache/.gnupg/.auto", "-d", "-o", $FTMP, $FGPG);
	$usr->{krypt} = -s $FTMP;
	if ($usr->{krypt})
	{ $dir->vecho(gettext("Verschluesselte Botschaft entziffert."));
	  unlink $FGPG unless $dir->bell('debug');
      }
	else
	{ $dir->vecho(gettext("Huch, Botschaft offenbar unverschluesselt."));
	  unlink $FTMP;
	  rename $FGPG, $FTMP;
      };
	
	open STDIN, "<$FTMP";
    };

  TOP: while (<STDIN>) {
      chop;
      if (/^(\w+)\s*=\s*(\S.*)\s*$/)
      { $dir->decho("line %s split into arg1 %s and arg2 %s", $_, $1, $2);
	my $uc = $1;$uc = uc($uc);
	my $bell = $AUTHBELLS{$uc};
	$dir->bellkv($bell, $2) if $bell;
	$dir->decho("Arg1: $1, UC: $uc, BELLS of $bell: %s", $dir->bell($bell));
	next TOP }
      
      do { push @{$usr->{toplines}}, $_;$dir->decho("\ttopline $_ pushed");last TOP } unless /^Hash:/ or /-----/; }

    $dir->bellkv('adm', (crypt($dir->bell('admpass'), $dir->{admpwx}) =~ /^$dir->{admpwx}$/)) unless $dir->bell('adm');
    $dir->decho("BELLS: %s", commed(map { sprintf "%s: %s", $_, $dir->bell($_); } keys %{$dir->{bell}}));
    return 1;
}


sub epatext {
    my ($usr, $dir) = verusr(shift) or return;
    my ($cmd, @args) = @_;
    local $_;
    $dir->decho("EPATEXT %s(%s)", $cmd, commed(@args));
  CMD: for ($cmd) {
      /\Aput\Z/ && return $usr->epatput(@args); 
      /\A(get|ins)\Z/ && return $usr->epatget(@args);
      /\Asend\Z/ && return $usr->epatsend(@args);
      /\Apicklist\Z/ && return lined($dir->pickpatlist);
      /\Apickfile\Z/ && return lined($dir->pickpatfile);
      /\A(stat|data|query|frage)\Z/ && return rows2text($usr->epat2rows(@args));
      return $dir->aua(55, gettext("unbekannter Befehl %s"), "epat $_");
  };
}

sub ocrpats {
    my ($usr, $dir, $pat, @pats) = ();
    ($usr, $dir) = verusr(shift) or return;
    $dir->decho("OCRPATS");
    return @{$usr->{ocrpats}} if $usr->{ocrpats};
    $dir->verdb('epat');
    my @records = $dir->{pgdb}{epat}->get_records('ocrplan', { uid=>$usr->{uid} }, 'pat');
    return unless @records;
    for (@records) { 
	($pat) = @$_;
	push @pats, $pat; 
    };
    @{$usr->{ocrpats}} = @pats;
    return @pats;
}

sub epatput {
    my ($usr, $dir) = verusr(shift) or return;
    local $_;
    my $relpaf = shift;
    my $prg = shift;
    my $ver = shift;
    $dir->decho("EPATPUT %s", commed($relpaf, $prg, $ver, $_[0]));
    my ($pat, $tarzip, $armor);
  PAT: for ($relpaf) {
      ($relpaf) = /^(\w[\w\.]+\w)$/;
      return $dir->aua(57, gettext("ungueltiger Dateiname %s"), $_) unless $relpaf;
      ($pat, $tarzip, $armor) = /^(\w+)\.(tar|tgz|tbz)\.(b64|uu)$/;
      last if $pat;
      ($pat) = /^(\w+)$/; 
      $relpaf .= ".txt";
  };
    $prg = "gocr" unless $prg;
    $ver = numchk($ver) || 3005;
    my @lines = $usr->ilines(@_);
    $dir->decho("\tpatent $pat, %d lines ocr-ed with $prg $ver, transported %s", $#lines, $tarzip ? "with $tarzip and $armor" : "as is");
    $pat = $dir->patid($pat) or return $dir->aua(56, gettext("%s ist keine Patentkennung"), $pat); 
    my @ocrpats = $usr->ocrpats;
    return $dir->aua(44, gettext("Nutzer %s hat Patentschrift %s nicht uebernommen"), $usr->{uid}, $pat) unless grep $pat, @ocrpats or $usr->perm('epat', 'put');
    my $absdir = $dir->pattxtdir($pat);
    my $abspaf = dirslashed($absdir, $relpaf);
    $dir->UMask('umask');
    ensure_writable($abspaf) or return $dir->aua(99, gettext("kann Datei %s nicht anlegen"), $abspaf);
    if (open FO, ">", $abspaf)
    { $dir->decho("\tschreibe in Datei $abspaf") }
    else { return $dir->aua(98, gettext("kann Datei %s nicht schreiben"), $abspaf); };
    binmode FO, ":utf8" if $UTF8;
    for (@lines) { print FO $_; };
    close FO; 
    if ($tarzip) { $usr->untarpack($abspaf, $absdir, $armor, $tarzip);unlink $abspaf; };
    system("chmod -R a+rX,ug+w $absdir");
    $dir->vecho(gettext("Die Patentschrift sollte nun unter %s zu lesen sein"), $dir->pattxturl($pat));
    $dir->verdb('epat');
    $dir->{pgdb}{epat}->query(sprintf("update ocrplan set commit = '%s', ocrprog = '%s', version = %d where pat = '%s' and uid = '%s'", $dir->dirdatestamp, $prg, $ver, $pat, $usr->{uid}));
    $dir->{pgdb}{epat}->query(sprintf("update patattr set txtok = true where pat = '%s'", $pat));
    return 1;
}

sub epatput_test {
    my $dir = verdir shift;
    my $tester = shift; 
    die "tester is not a ref" unless ref $tester;
    my $uid = $tester->{uid};
    $dir->decho("EPATPUT testen");
    my ($i, $fo, @files) = ();
    for ($i = 0; $i < 16; $i++) {
	$fo = sprintf("NUR_EIN_TEST_%02d.txt", $i);
	push @files, $fo;
	die "kann Datei $fo nicht schreiben" unless open FO, ">", $fo;
	printf FO "$fo\ntest\nblablabla\n$$\n";
	close FO;
    };
    my $pat = "ep2123456";
    my $tgz = "$pat.tgz.b64";
    $dir->exek("tar czvf - @files | mimencode > $tgz");
    $dir->direxit if $dir->lasterror;
    $dir->{pgdb}{epat}->edit('patattr', { pat=>$pat }, swprob=>0);
    $dir->{pgdb}{epat}->edit('ocrplan', { pat=>$pat }, uid=>$uid);
    die "cant read from $tgz" unless open TGZ, "<", $tgz;
    my @lines = <TGZ>;
    close TGZ;
    $tester->epatput("$pat.tgz.b64", "frozr", "1007", @lines); 
    $dir->direxit if $dir->lasterror;
    $dir->{pgdb}{epat}->delete('ocrplan', pat=>$pat);
    $dir->{pgdb}{epat}->delete('patattr', pat=>$pat);
    my $patdir = $dir->pattxtdir($pat);
    $dir->direxit if $dir->lasterror;
    die "Verzeichnis $patdir existiert nicht" unless -r $patdir and -d $patdir;
    $dir->exek("ls -l $patdir");
    $dir->direxit if $dir->lasterror;
    for ($i = 0; $i < 16; $i++) {
	$fo = join("/", $patdir, sprintf("NUR_EIN_TEST_%02d.txt", $i));
	die "$fo nicht vorhanden" unless -r $fo;
	unlink $fo;
    };
    for ($i = 0; $i < 16; $i++) {
	$fo = sprintf("NUR_EIN_TEST_%02d.txt", $i);
	unlink $fo;
    };
    unlink $tgz;
};


sub faddids {
    my ($fio, @ids) = @_;
    return unless @ids;
    return unless -w $fio;
    local $_;
    if (-r $fio and open FI, "<$fio") { 
	my ($line, $tab);
	while ($line = <FI>) { if (($tab) = $line =~ /\A(\w+)\b/) { push @ids, $line unless grep /\A$tab\b/, @ids; } };close FI; }; 
    if (open FO, ">$fio") { print FO lined @ids;close FO; };
}

sub epatget {
    my ($usr, $dir, $pat, $fo, @pats);
    ($usr, $dir) = verusr(shift) or return;
    local $_;
    $dir->decho("EPATGET");
    @pats = $usr->ilines(@_);
    $fo = dirslashed $usr->{udir}, ".epatget.txt";
    faddids($fo, @pats);
    $dir->exekaua(77, "epgcatall $fo");
    foreach $pat (@pats) { print $dir->paturl($pat), "\n"; };
    return 1 unless $dir->{err};
};

sub epatsend {
    my ($usr, $dir, $pat, $fo, $fi1, $fi2, @pats);
    ($usr, $dir) = verusr(shift) or return;
    local $_;
    $dir->decho("EPATSEND");
    @pats = $usr->ilines(@_);
    $fo = dirslashed $usr->{udir}, ".epatget.txt";
    faddids($fo, @pats);
    $fo = dirslashed $usr->{udir}, ".epatsend.txt";
    if (open FO, ">>$fo") { for (@pats) { print FO $_, "\n"; };close FO; };
    $dir->exekaua(73, "epgcatall $fo");
    foreach $pat (@pats) { $fi1 = dirslashed($dir->pattxtdir($pat), "absdata");$fi2 = $dir->patimgpaf($pat);next unless -r $fi1 and -r $fi2;$dir->exek("metasend -b -z -m 'text/plain' -f %s -e 7bit -s 'ffii epat send %s' -D absdata -n -m 'image/pdf' -f %s -D PDF -e 8bit -t %s", $fi1, $pat, $fi2, $usr->{mail}); };
}

sub epatusage { return sprintf gettext("EPAT: Abfrage der Patent-Datenbank auf FFII.org\nErklaerungen finden sich unter\n\n\t%s\n"), "http://www.ffii.org/verein/knecht/epat/"; };

sub ml2html { # "das %(q:abc)" => "das &quot;abc&quot;"
    my $str = shift;
    while (1) {
	next if $str =~ s(\%[\(]q:([^\(\)]*)[\)])(&quot;$1&quot);
	next if $str =~ s(\%[\(]s:([^\(\)]*)[\)])(<strong>$1</strong>);
	next if $str =~ s(\%[\(]e:([^\(\)]*)[\)])(<em>$1</em>);
	next if $str =~ s(\%[\(](\w+):([^\(\)]*)[\)])(<$1>$2</$1>);
	last;
    }
    return "$str";
}
sub ml2latex {
    my $str = shift;
    while (1) {
	next if $str =~ s(\%[\(]q:([^\(\)]*)[\)])(``$1'');
	next if $str =~ s(\%[\(]s:([^\(\)]*)[\)])({\\bf $1});
	next if $str =~ s(\%[\(]e:([^\(\)]*)[\)])({\\em $1});
	next if $str =~ s(\%[\(](\w+):([^\(\)]*)[\)])({\\$1 $2});
	last;
    }
    $str =~ s/[\&\%\#\$\_]/\\$1/g;
    $str =~ s/[\\]/\$\\backslash\$/g;
    $str =~ s/\^/\$\\wedge\$/g;
    $str =~ s/\"/''/g;
    $str =~ s/[\<\>]/\$$1\$/g;
    return $str;
}

my %HTMLALIGN = ( l=>"left", c=>"center", r=>"right" );
sub htmlalign {
    my $str = shift || "l";
    return $HTMLALIGN{$str};
}

sub epat2rows {
    my ($pat, $ntup, $sql, $select, $group, $order, $wherestr, $havingstr, @where, @having, $i, $j, $w, $c, $cmd, $val, $datum, $checkout, $pgcheckout, $paturlrow, $texpr, $htmpr, $fmt, $ipat, @lines, @rows, @row, @tabs, @tabslo, @vals, @tits, @cols, %col, %outfile) = ();
    my ($usr, $dir) = verusr(shift) or return;
    $dir->decho("EPAT2ROWS");
    return unless $dir->verdb('epat');
    @lines = $usr->ilines(@_);
    local $_;
    my $fo = dirslashed $usr->{udir}, ".epat2rows.txt";
    if (open FO, ">>$fo") { for (@lines) { print FO $_, "\n" if $_; };close FO; };
    my $db = "epat";
    my $nmaxlim = zor($usr->perm('epatnmax'), $usr->perm('rdbnmax'));
    my $nmax = $nmaxlim;
    $dir->decho("NMAX %d", $nmax);
    my $progclm = 3;
    my $border = 0;
    my $padding = 20;
    my $envir = 1;
    my $swprob = 950;
    my $nextrow = sub { push @rows, [ @_ ] };
    my $datestamp = $dir->dirdatestamp;
    $col{patcnt}{sql} = "count(pat)";
    $col{pubjar}{sql} = "substring(pubdat, 1, 4)";
  SEND: while (@lines) {
      $dir->decho("\tSEND: %d lines remaining", $#lines);
      ($sql, $wherestr, $order, $havingstr, $group, @tabs, @cols, @where, @having, @tabslo, @tits, %outfile) = ();
      my $line;
    LINE: while (@lines) {
	$line = shift @lines;
	$dir->decho("\tLINE: line $line"); 
	($cmd, $val) = $line =~ m(\A(\w+)\s*(.*)\s*\Z);
	@vals = split /[\s\,]+/, $val;
	next LINE unless $cmd;
      CMD: for ($cmd) {
	  /\A(invland|appland|pubdat|jarappl|swpat|(ip|ec)class)\Z/ && do { @tabs = ("patattr", ($cmd =~ /^(ip|ec)class$/) ? $cmd : "absdata" );@where = ("(swprob > $swprob or progclm > 0)"); };
	  /\A(appland|invland)\Z/ && do { push @where, "land is not null"; };
	  /\A(appland|jarappl|swpat)\Z/ && do { push @tabs, "applicant"; };
	  /\A(invland|appland|jarappl)\Z/ && do { push @having, "count(pat) > 2"; };
	  /\Ainvland\Z/ && do { @cols = ("land", "patcnt");push @tabs, "inventor";$group = "group by land";$order = "order by count(pat) desc";last };
	  /\Aappland\Z/ && do { @cols = ("land", "patcnt");$group = "group by land";$order = "order by patcnt desc";last };
	  /\Apubdat\Z/ && do { @cols = ("pubjar", "patcnt");$group = "group by pubjar";push @where, "pubdat is not null";$order = "order by pubjar desc";last };
	  /\Ajarappl\Z/ && do { @cols = ("pubjar", "applicant", "patcnt");push @where, "pubdat is not null", "applicant is not null";$group = "group by pubjar, applicant";$order = "order by pubjar desc, patcnt desc";last };
	  /\A(ip|ec)class\Z/ && do { @cols = ($cmd, "patcnt");$group = "group by $cmd";push @having, "count(pat) > 20";$order = "order by patcnt desc";last };
	  /\Aepat\Z/ && do { $db = "";if (@cols) { @cols = nodups("pat", @cols) } else { @cols = ("pat", "tech", "deal", $dir->{pgdb}{new} ? "epatrem" : "rem") };push @tabs, "epat";$order = "order by tech asc, deal asc, pat desc";push @where, "tech > 0";last };
	  /\Aswpat\Z/ && do { @cols = ("pat", "applicant", "invention");push @where, "pubdat like '$datum%'";$order = "order by applicant";last };
	  /\Acheckout\Z/ && do { return $dir->aua(111, gettext("unerlaubter Befehl %s"), $cmd) unless $usr->{perm}{patocr};$checkout = 1;push @cols, "pat";@tabs = "patattr";push @tabslo, "ocrplan";$wherestr = sprintf("(uid = '%s' and not txtok) or (reqb1 and not txtok and uid is null and (swprob > $swprob or progclm > 3))", $usr->{uid});$order = "order by swprob desc";$dir->decho("\tcheckout wherestr: $wherestr");last };
	  /\Asend\Z/ && do { $dir->decho("\tlast LINE");last LINE; };
	  /\Atits\Z/ && do { @tits = @vals;last }; 
	  /\Acols\Z/ && do { @cols = @vals;last };
	  /\Acol\Z/ && do { $col{wd}{$vals[0]} = $vals[1];$col{al}{$vals[0]} = $vals[2];last };
	  /\Atabs\Z/ && do { @tabs = @vals;last };
	  last unless @vals;
	  /\Adatum\Z/ && do { ($datum) = $val =~ /^(\d{4}[\-\d]*)$/;last unless $datum;push @tabs, "absdata";push @where, "pubdat like '$datum%'";last };
	  /\Aoutfile\Z/ && do { $outfile{$vals[0]} = $vals[1];last };
	  /\Afmt\Z/ && do { $fmt = $vals[0];for ($fmt) { /^tabs$/ && do { $nextrow = sub { print(coltabbed(@_), "\n") };last };/^perl$/ && do { $nextrow = sub { push @rows, [ @_ ] };last };/^null$/ && do { $nextrow = sub { } }; };last };
	  /\A(border|envir|padding|nmax|swprob|progclm)\Z/ && do { $val = numchk($vals[0]);return $dir->aua(53, "ungueltiger Zahlenwert %s", $vals[0]) unless defined $val; };
	  /\Aswprob\Z/ && do { $swprob = max(950, $val); };
	  /\Aprogclm\Z/ && do { $progclm = $val; };
	  /\Aenvir\Z/ && do { $envir = $val;last }; 
	  /\Aborder\Z/ && do { $border = $val;last };
	  /\Apadding\Z/ && do { $padding = $val;last };
	  /\Anmax\Z/ && do { $nmax = limchk($val, $nmaxlim);last };
	  /\Apatids\Z/ && do { push @where, sprintf("pat in ( %s )", sqcommed(@vals));last };
	  /\Asql\Z/ && do { return $dir->aua(111, gettext("unerlaubter Befehl %s"), $cmd) unless $usr->{perm}{sql};$sql = $val;last };
	  $dir->vecho(&epatusage);
	  return $dir->aua(110, gettext("unbekannter Befehl %s"), $_);
      };
	$dir->decho("\tcmd $cmd; val $val; vals %s; finito", commed(@vals));
    }; # LINE block end
    CALC: {
	@tabs = nodups(@tabs);@cols = nodups(@cols);
	$w = 100;$c = $#cols;
	for (@cols) { $col{al}{$_} = "l" unless $col{al}{$_};if ($col{wd}{$_}) { $w -= $col{wd}{$_};$w -= 4;$c--; }; };
	$w /= $c if $c > 0 and $w > 0;
	for (@cols) { $col{wd}{$_} = $w unless $col{wd}{$_};$dir->decho("\tnow align of %s is %s; width is %s", $_, $col{al}{$_}, $col{wd}{$_}); }; 
	do { $select = sprintf("select %s from %s", commed(map { $col{$_}{sql} ? sprintf("%s as %s", $col{$_}{sql}, $_) : $_; } nodups(@cols)), join(" natural left outer join ", join(" natural join ", nodups(@tabs)), nodups(@tabslo)));
	     $dir->decho("\twherestr 1: $wherestr; havingstr 1: $havingstr");
	     $wherestr = join(" and ", @where) if @where and not $wherestr;
	     $havingstr = join(" and ", @having) if @having and not $havingstr;
	     $dir->decho("\twherestr 2: $wherestr; havingstr 2: $havingstr");
	     next SEND unless $wherestr;
	     $sql = spaced($select, "where", $wherestr, $group, $havingstr && spaced("having", $havingstr), $order);
	 } unless $sql; }; # end CALC
    EXEC: {
	$dir->vecho("\tEXEC: outfiles %s: %s", commed(values %outfile), $sql) if %outfile;
	return unless $dir->verdb($db);
	my @records = $dir->{pgdb}{$db}->get_records($sql);
	return unless $rows > 0;
	next SEND unless @records;
	$ntup = limchk(scalar @records, $nmax);
	$dir->decho("\tntup: $ntup, nmax: $nmax, nmaxlim: $nmaxlim in epat2rows");
	$pgcheckout = $checkout ? sub { my $pat = shift;return unless $pat;$dir->decho("\tpgcheckout: %s", $pat);return $dir->{pgdb}{epat}->edit('ocrplan', { pat=>$pat }, uid=>$usr->{uid}, checkout=>$datestamp) } : sub { };
	$ipat = lindex("pat", 0, @cols);
	if ($outfile{html}) { open HTML, ">", $outfile{html} or return $dir->aua(73, "kann nicht in %s schreiben", $outfile{html});$htmpr = sub { my $str = shift;print HTML sprintf("$str\n", @_); }; } else { $htmpr = sub { }; };
	if ($outfile{latex}) { open LATEX, ">", $outfile{latex} or return $dir->aua(72, "kann nicht in %s schreiben", $outfile{latex});$texpr = sub { my $str = shift;print LATEX sprintf("$str\n", @_) } } else { $texpr = sub { }; };
	if ($ipat >= 0) { $paturlrow = sub { my (@row) = @_;$row[$ipat] = sprintf("<a href=\"%s\">%s</a>", $dir->paturl($row[$ipat]), $row[$ipat]);return @row; } } else { $paturlrow = sub { return @_ } };
	my $hsep = $border ? "|" : "";
	my $vsep = $border ? "\\hline" : "";
	if ($envir)
	{ @tits = @cols unless @tits;
	  &$nextrow(@tits);
	  &$htmpr("<table border=%d cellpadding=%d>\n<tr>%s</tr>", $border, $padding, join("", map { "<th>$_</th>" } @tits));
	  &$texpr("\\begin{longtable}{%s}$vsep\n%s\\\\$vsep\\endhead", enclosed(join($hsep, do { map { sprintf("%s{%02d}", uc($col{al}{$_}), $col{wd}{$_}) } @cols }), $hsep), join(" & ", map { ml2latex($_); } @tits)); };
	for (my $i = 0; $i < $ntup; $i++) {
	    @row = @{$records[$i]};
	    &$nextrow(@row); 
	    &$pgcheckout($row[$ipat]) unless $ipat > $#row; 
	    &$texpr("%s\\\\%s", join(" & ", map { ml2latex($_) } @row), $vsep);
	    @row = &$paturlrow(@row) unless $ipat > $#row;
	    $j=0;$c=$cols[$j];&$htmpr("<tr><th align=%s width=\"%d%%\">%s</th>%s</tr>", htmlalign($col{al}{$c}), $col{wd}{$c}, $row[0], join("", do { map { $j++;$c=$cols[$j];sprintf("<td align=%s width=\"%s%%\">%s</td>", htmlalign($col{al}{$c}), $col{wd}{$c}, ml2html($_)); } @row[1..$#row] }));
	};
	if ($envir) { &$htmpr("</table>");&$texpr("\\end{longtable}"); }

    }; # end EXEC
  }; # end SEND
    return @rows;
}; # end epat2rows

sub getvdefs {
    my $dir = shift;
    my ($i, $key, $val, $npkey, $nbval, $kmd, @vals);
    local $_;
    $dir->decho("GETVDEFS");
    my $fi =  dirslashed $dir->{frmbas}, join(".", $dir->bell('vdefs'), "txt");
    -r $fi or return $dir->aua(101, gettext("Verbdefinitionen %s fehlen"), $fi);
    open FD, "<", $fi or return $dir->aua(100, gettext("kann Verbdefinitionen %s nicht oeffnen"), $fi);
    my $line;
    while ($line = <FD>)
    { chomp($line);
      if ($line =~ m(\A(\w+)\s+(\w+)\s*(.*)\s*\Z)) {
	  for ($line) {
	      ($key, $val) = ($2, $3);
	      /^nodb/ && do { $dir->{vdefs}{$key}{nodb} = 1;last };
	      /^tab\s+$key\s+(.*):\s+(.*)\s*$/ && do { @{$dir->{vdefs}{$key}{lkeys}} = split /\s+/, $1;@{$dir->{vdefs}{$key}{rkeys}} = split /\s+/, $2;last };
	      @vals = split /\s+/, $val;
	      /^fld/ && do { ($dir->{vdefs}{$key}{typ}, $dir->{vdefs}{$key}{len}) = @vals;last };
	      /^mov/ && do { 
		  $dir->{vdefs}{$key}{mov} = $vals[0];
		  $i=1;
		  while ($i < $#vals) { 
		      $kmd = $vals[$i];
		      return $dir->aua(53, "Syntaxfehler in mov: kommando %s unbekannt", $kmd) unless grep $kmd, 'key', 'val', 'rev';
		      $nbval = ($kmd =~ /\Arev\Z/) ? 2 : 1;
		      $npkey = $i+$nbval+1;
		      $dir->{vdefs}{$key}{&tabbed("mov", $vals[$npkey])} = tabbed(@vals[$i..$i+$nbval]);$i=$npkey+1 };
		  last };
	  } } };

    { no strict;$dir->bell('debug') && printf STDERR "VDEFS: %s\n", vjoin("\n\t", map { $i=$_;vjoin(": ", $i, vjoin("\n\t\t", map { sprintf "%s = %s", $_, @{$dir->{vdefs}{$i}{$_}} ? commed(@{$dir->{vdefs}{$i}{$_}}) : $dir->{vdefs}{$i}{$_} } (keys %{$dir->{vdefs}{$i}}))); } keys %{$dir->{vdefs}}); }

    close FD;
    return 1;
}

sub numchk {
    my ($str, $len) = @_;
    $str =~ tr/\,/\./;
    return unless $str =~ /^[\+\-]?\d[\d\.\s]*$/;
    my $num = $str*1;
    my $slen = length(int($num));
    return if ($slen == 0 or ($len and $slen > $len));
    return $num;
}
sub limchk {
    my ($str, $num, $lim);
    ($num, $lim) = @_;
    return $num unless $lim;
    return $num unless $num > $lim;
    return $lim;
};
sub boolchk {
    my $str = shift;
    return 1 if $str =~ /^(1|Y|y|T|t|\+)/;
    return 0 if $str =~ /^(0|N|n|F|f|\-)/;
}
sub datechk {
    local $_;
    for (shift) {
	/^\d{4}-\d{2}-\d{2}$/ && return $_;
	/^(\d{4})(\d{2})(\d{2})$/ && return "$1-$2-$3";
	/^(\d{2})(\d{2})(\d{2})$/ && return "20$1-$2-$3";
    }
};
sub vtypchk { 
    my $dir = verdir(shift) or return;
    my ($key, $val) = @_;
    local $_;
    $dir->decho("VTYPCHK key: $key, val: $val");
    my $typ = $dir->{vdefs}{$key}{typ};
    my $len = $dir->{vdefs}{$key}{len};
    $dir->decho("VTYPCHK: verify verb key: $key, val: $val, typ: $typ, len: $len");
    my ($res);
    for ($typ) { 
	/^b$/ && do { $res = boolchk($val);last };
	/^[ni]\d*$/ && do { $res = numchk($val, $len);last };
	/^v\d*$/ && do { $res = $val unless $len and length($val) > $len;last };
	/^d$/ && do { $res = datechk($val);last };
	/^t$/ && do { $res = $val;last };
	return $dir->aua(54, gettext("vtypchk: Unbekannter Typ %s fuer Kategorie %s Wert %s"), $_, $key, $val);
    };
    return $dir->aua(53, gettext("Der Wert %s passt nicht zum Typ %s"), $val, $typ . $len) unless defined $res;
    $dir->decho("\tkey: $key; val: $val; typ: $typ; res: $res");
    return $res;
}

sub i2u {
    my $dir = verdir(shift) or return;
    my ($str) = @_;
    return $str if $UTF8 or $dir->bell('bytechar');
    open STDERR, ">/dev/null" unless $dir->bell('utf8debug');
    my @cchars = unpack "C*", $str;
    printf "CCHARS: %s, %s\n", $str, spaced @cchars, "\n" if $dir->bell('utf8debug');
    my @uchars = unpack "U*", $str;
    printf "UCHARS: %s, %s\n", $str, spaced @uchars, "\n" if $dir->bell('utf8debug');
    do { close STDERR;open STDERR, ">&SAVERR" } unless $dir->bell('utf8debug');
    print "I2U MAP: " if $dir->bell('utf8debug');
    my $i=-1;
    my @result = map { my $c = $_;$c = 0 if $c == 65533;$i++ if $c > 2047;$i++ if $c > 127;$i++;print "$c " if $dir->bell('utf8debug');if ($c =~ m(\A0\Z)) { printf "invalid char %d: %d\n", $i, $cchars[$i] if $dir->bell('utf8debug');$cchars[$i] } else { $c }; } @uchars;
    print "\n" if $dir->bell('utf8debug');
    $str = pack("U*", @result);
    printf "I2U RESULT STR: %s\n", $str if $dir->bell('utf8debug');
    return $str;
}

sub sqlputpw  { 
    my ($usr, $dir) = verusr(shift) or return;
    my $pwx = shift;
    $dir->decho("SQLPUTPW: put crypted password $pwx of user $usr->{uid} into ffii database");
    return $dir->aua(163, gettext("Leeres Passwort")) unless $pwx;
    return $dir->aua(164, gettext("Leerer Benutzer")) unless $usr->{uid};
    $dir->verdb;
    return $dir->{pgdb}{ffii}->edit('pass', { uid=>$usr->{uid} }, pass=>$pwx);
};

sub sqlgetpw {
    my ($dir, $uid) = @_;
    $dir->decho("SQLGETPW: retrieve crypted password of user $uid from database");
    $dir->verdb;
    my ($pass) = $dir->{pgdb}{ffii}->get_record('pass', { uid =>$uid }, 'pass');
    return $pass;
}

sub readlines {
    my ($line, $nextline, @lines);
    $line = "";
    for (@_) {
	chop;
	($nextline) = /^([^\#]*)/;
	($nextline) = $nextline =~ /^(.*)\s*$/;
	if ($nextline =~ /^(.*)\\$/) {
	    $line .= $1; 
	    next;
	} else {
	    $line .= $nextline;
	};
	do { push @lines, $line;$line = ""; } if $line;
    }
    return @lines;
};

sub flines {
    my ($usr, $dir) = verusr(shift) or return;
    my $file = shift || $usr->{abspaf};
    $dir->decho("FLINES: %s", $file);
    return unless open FI, "<", $file;
    my @lines = readlines(<FI>);
    close FI;
    $dir->decho("\t%d lines", $#lines+1);
    return @lines;
}

sub vsetlocale { 
    my ($dir, $locale) = @_;
    $dir->decho("Set Locale %s", $locale);
    for ($locale) {
	/^de/ && do { $locale = "de_DE"; }; 
	/^fr/ && do { $locale = "fr_FR"; };
	$locale = "en_US";
    };
    $dir->bellkv(locale=>$locale);
    return $dir->aua(183, gettext("konnte Locale nicht auf %s setzen"), $locale) unless setlocale(LC_MESSAGES, $locale);
    return 1; };

$ENV{PATH} = "/usr/bin:/bin";
my @PGDBs = qw/epat ffii meps/;

sub read_interndir { 
    my $dir = shift;
    $dir->decho("READ_INTERNDIR interndir $interndir logdir $logdir tarX $tarX");
    my $interndir = dirslashed $dir->{homedir}, ".intern";
    my $logdir = dirslashed $interndir, "log";
    my $tarX = dirslashed $dir->{homedir}, "tarX.txt";
    $dir->{tarX} = $tarX if -r $tarX;
    my $fi = dirslashed $interndir, "nonuid";
    if (-r $fi and open FI, "<$fi") {
	while (<FI>) { /^(\w+)\b/ && push @items, $1; };
	close FI;
    } else { $dir->decho("Konnte Datei %s nicht lesen", $fi) };
    @{$dir->{nonuid}} = @items;
    $fi = dirslashed $interndir, "nonupw";@items = ();
    if (-r $fi and open FI, "<$fi") {
	while (<FI>) { /^(\w+)\b/ && push @items, $1; };
	close FI;
    } else { $dir->decho("Konnte Datei %s nicht lesen", $fi) };
    @{$dir->{nonupw}} = @items;
    $dir->decho("%d nonuid: %s", $#{$dir->{nonuid}}, join(", ", @{$dir->{nonuid}}));
    $dir->decho("%d nonupw: %s", $#{$dir->{nonupw}}, join(", ", @{$dir->{nonupw}}));
    $fi = dirslashed $interndir, ".admpass";
    if (-r $fi and open FI, "<$fi") 
    { $line = <FI>;
      chomp($line);
      if ($line =~ /^\w+\s*$/) {
	  $dir->{admpwx} = $line; 
      } else { $dir->aua(179, gettext("Als Adminpasswort wurde nur '%s' gefunden.  Unbrauchbar."), $line); };
      close FI; 
  } else { $dir->aua(174, gettext("Konnte Datei %s nicht lesen"), $fi) }; 
    return $dir; }

sub newdir {
    my $class = shift;
    my $dir = { };
    bless $dir, $class;
    my ($line, $item, @items);
    $line = shift or $dir->aua(74, gettext("Verzeichnis-Argument fehlt"));
    open FLOG, ">>", $FLOG;
    $dir->decho("NEWDIR $line");
    $dir->setbells(@_);
    local $_;
    if (($item) = $line =~ m(\A(/\w[/\w]+)\Z)) { $dir->{pafbas} = $item } else { $dir->{pafbas} = '/bmore' };
    return $dir->aua(89, gettext("unbekanntes Verzeichnis %s"), $dir->{pafbas}) unless -d $dir->{pafbas};
    $dir->vsetlocale($dir->bell('locale'));
    $dir->{frmbas} = dirslashed $dir->{pafbas}, 'www', 'verein';
    $dir->{homedir} = dirslashed $dir->{frmbas}, 'leute';
    if ($dir->bell('rdbonly')) { $dir->{admpwx} = $dir->sqlgetpw('knecht'); } else { $dir->read_interndir;return if $dir->lasterror; };
    $dir->getvdefs or return;
    $dir->{patdir} = dirslashed $dir->{pafbas}, 'swpat', 'pikta';
    my ($sek, $min, $hor, $mdi, $mon, $jar) = gmtime(time);$jar %= 100;$mon++;
    $dir->{dies}{sek} = $sek;
    $dir->{dies}{min} = $min;
    $dir->{dies}{hor} = $hor;
    $dir->{dies}{mdi} = $mdi;
    $dir->{dies}{mon} = $mon;
    $dir->{dies}{jar} = $jar;
    if ($dir->bell('initdbs')) { for (@PGDBs) { $dir->verdb($_) } }; 
    # $dir->decho(Dumper($dir)) if $dir->bell('debug');
    return $dir;
}

sub newuserp {
    my $dir = verdir(shift) or return;
    my $user = shift;
    # IMPORTANT: do not change sequence of error messages
    # This function must be usable as a test of whether a user exists, regardles of whether her name is too short
    return $dir->aua(38, gettext("Kennung %s ist besetzt."), $user) if grep /$user/, @{$dir->{nonuid}};
    return unless $dir->verdb;
    my ($old_user) = $dir->{pgdb}{ffii}->get_record('pnom', { uid=>$user }, 'uid');
    return $dir->aua(37, gettext("Kennung %s ist vergeben"), $user) if $old_user;
    return $dir->aua(34, gettext("Kennung %s besteht nicht aus 5-8 Buchstaben!"), $user) unless $user =~ m(\A[a-z]{5,8}\Z);
    return $user;
}

sub userexistsp {
    my ($dir, $user) = @_;
    $dir->{err} = 0;
    $user = $dir->newuserp($user);
    return $user if $dir->{err} == 37;
}

sub randuserid {
    my $dir = verdir(shift) or return;
    $dir->decho("RANDUSERID");
    my ($try, $uid) = ();
    for (0..10) {
	$try = join('', ('a'..'z')[rand 26, rand 26, rand 26, rand 26, rand 26, rand 26, rand 26]);
	$dir->decho("\tTRY %d: %s", $_, $try);
	do { $uid = $try;last } if $dir->newuserp($try); }
    return $uid;
}

sub passwdp {
    my $dir = verdir(shift) or return;
    my ($pass, @nonupw) = @_;
    $dir->decho("PASSWDP: is %s a valid password?", $pass);
    return $dir->aua(32, gettext("ungeeignetes Passwort %s.\nDas Passwort muss 5-12 alphanumerische Zeichen enthalten."), $pass) unless $pass =~ /^\w{5,12}$/;
    return $dir->aua(31, gettext("ungeeignetes Passwort %s.\nDas Passwort darf nicht leicht erratbar sein."), $pass) if grep /$pass/, @nonupw, @{$dir->{nonupw}}, @{$dir->{nonuid}};
    return $pass;
}

sub randpasswd {
    my $dir = verdir(shift) or return;
    $dir->decho("RANDPASSWD");
    my ($try, $upw) = ();
    for (0..10) {
	$try = join('', (0..9, 'A'..'Z', 'a'..'z')[rand 62, rand 62, rand 62, rand 62, rand 62, rand 62, rand 62]);
	$dir->decho("\tTRY %d: %s", $_, $try);
	do { $upw = $try;last } if $dir->passwdp($try); }
    return $upw;
}

sub ilines { 
    my ($usr, $dir) = verusr(shift) or return;
    my @lines = @_;
    $dir->decho("ILINES input %d lines", $#lines+1);    
    return (@{$usr->{toplines}}, @lines) if $#lines > 0;
    $dir->decho(gettext("Erwarte Eingabe von STDIN..."));
    @lines = readlines(<STDIN>);
    $dir->decho("ILINES output %d lines", $#lines+1);
    return @lines;
}

sub chid {
    my ($usr, $dir) = verusr(shift) or return;
    my $id2 = shift;
    my $id1 = $usr->{uid};
    local $_;
    my ($item);
    $dir->decho('CHID %s ==> %s', $id1, $id2);
    return $dir->aua(36, gettext("Benutzer %s darf seinen Namen nicht aendern"), $usr->{uid}) unless $usr->perm('chid') or $dir->bell('adm');
    return $dir->aua(92, gettext("Kann nicht '%s' zu '%s' umbenennen"), $id1, $id2) unless $id1 and $id2 and not $id1 =~ /\A$id2\Z/;
    ($item) = $id2 =~ m(\A(\w{3,9})\Z);
    return $dir->aua(91, gettext("ungueltiger Benutzername %s"), $id2) unless $item;
    $id2 = $item;
    unless ($dir->bell('rdbonly')) {
	my $id1dir = $usr->{udir};
	return $dir->aua(90, gettext("Verzeichnis %s nicht vorhanden"), $id1dir) unless $id1dir and -d $id1dir;
	my ($id21, $id22) = (substr($id2, 0, 2), substr($id2, 2));
	my $id2upd = dirslashed $dir->{homedir}, $id21;
	-d $id2upd or $dir->exekaua(88, "mkdir -p $id2upd");
	my $id2dir = dirslashed $id2upd, $id22;
	return $dir->aua(87, gettext("Das zu erzeugendes Nutzerverzeichnis %s ist bereits vorhanden"), $id2dir) if -d $id2dir;
    };
    return unless $dir->verdb;
    my($tab, @uidtabs);
    @uidtabs = $dir->uidtabs;
    @uidtabs = grep { ! /\Apnom\Z/ } @uidtabs;
    $dir->decho(gettext("uidtabs ohne pnom: %s"), commed(@uidtabs));
    my ($old_user) = $dir->{pgdb}{ffii}->get_record('pnom', { uid=>$id2 }, 'uid');
    return $dir->aua(85, gettext("Umbenennung von %s zu %s unmoeglich, da letzterer bereits in der Datenbank existiert."), $id1, $id2) if $old_user;
    # return $dir->aua(84, gettext("Unbenennug von %s zu %s nicht moeglich, da ersterer nicht mit Namen bekannt ist."), $id1, $id2) unless $uid;
    $usr->{uid} = $id2;
    $usr->{udir} = $id2dir unless $dir->bell('rdbonly');
    if (grep { /\Auid\Z/ } @{$usr->{lkeys}}) { @{$usr->{lvals}} = map { $usr->{$_} } @{$usr->{lkeys}}; };
    my ($uid, $pntyp, $pnom) = $dir->{pgdb}{ffii}->get_record('pnom', { uid=>$id1 }, qw(uid pntyp pnom));
    if ($pnom) { # needed only if user is already in database, not for renaming at beginning of registration
	$dir->{pgdb}{ffii}->edit('pnom', { uid=>$id2 }, pntyp=>$pntyp, pnom=>$pnom);
	foreach $tab (@uidtabs) { $dir->{pgdb}{ffii}->query(qq{update $tab set uid = '$id2' where uid = '$id1'}) };
	my $rows = $dir->{pgdb}{ffii}->delete('pnom', { uid=>$id1 });
	# $dir->aua(83, gettext("Konnte Namensleiche %s nicht beseitigen"), $id1) unless $rows > 0;
	$dir->exekaua(86, "mv -vf $id1dir $id2dir") unless $dir->bell('rdbonly');
    };
    return $usr->{uid};
}

sub chid_test { 
    my ($usr, $dir) = verusr(shift) or return;
    my $uid = $usr->{uid};
    $dir->{pgdb}{ffii}->edit('mail', { uid=>$uid, mailref=>'norm' }, mailuser=>$uid, mailhost=>'ffii.org');
    my $id2 = $dir->randuserid;
    printf STDERR "KENNUNG %s zu \%s ÄNDERN...", $uid, $id2; 
    $usr->chid($id2);
    $dir->direxit if $dir->lasterror;
    $usr->user2psql;
    $dir->direxit if $dir->lasterror;
    my @records = $dir->{pgdb}{ffii}->get_records('mail', { uid=>$id2 });
    die "user $uid not renamed to $id2 in database.\nKO" unless @records;
    @records = $dir->{pgdb}{ffii}->get_records('mail', { uid=>$uid });
    die "Spurious user $uid still exists in mail table, should have been renamed to $id2!\nKO" if @records;
    @records = $dir->{pgdb}{ffii}->get_records('pnom', { uid=>$uid });
    die "Spurious user $uid still exists in pnom table, should have been renamed to $id2!\nKO" if @records;
    if ($usr->{uid} =~ /\A$id2\Z/ and grep { /\A$id2\Z/ } @{$usr->{lvals}}) {
	$dir->decho("OK");
    } else { $dir->decho("KO");exit 1; };
    printf STDERR "KENNUNG %s zu \%s ZURUECKSETZEN...", $id2, $uid;
    $usr->chid($uid);
    $dir->direxit if $dir->lasterror;
    if ($usr->{uid} =~ /^$uid$/) {
	$dir->decho("OK");
    } else { $dir->decho("KO");exit 1; }; 
    @records = $dir->{pgdb}{ffii}('mail', { uid=>$uid });
    die "user $uid not renamed in database.\nKO" unless @records;
    @records = $dir->{pgdb}{ffii}('mail', { uid=>$id2 });
    die "Spurious user $id2 still exists in database!\nKO" if @records;
};

sub chpw {
    my ($usr, $dir) = verusr(shift) or return;
    local $_;
    my ($pw, @nonupw) = @_;
    $dir->decho("CHPW $pw");
    return $dir->aua(35, gettext("Benutzer %s darf sein Passwort nicht aendern"), $usr->{uid}) unless $usr->perm('chpw');
    return unless $dir->passwdp($pw, @nonupw);
    my $crypt = crypt($pw, $dir->{admpwx});
    $dir->decho("CHPW crypting %s with admpwx %s resulted in %s", $pw, $dir->{admpwx}, $crypt);
    if ($dir->bell('txtonly')) {
	my $fo = dirslashed $usr->{udir}, ".pass";
	open FO, ">", $fo or return $dir->aua(97, gettext("kann nicht in Datei %s schreiben"), $fo);
	$dir->vecho(gettext("Aendere Personenregister"));
	printf FO sprintf("%s\n%s\n", $crypt, $usr->{mail});
	close FO; }
    else { $usr->sqlputpw($crypt); };
    return $crypt;
}

sub newuser {
    my $class = shift;
    my $usr = { };
    bless $usr, $class;
    local $_;
    my $dir = shift;verdir $dir or return;$usr->{dir} = $dir;
    $dir->vecho(gettext("KNECHT im Hause FFII.org\nIch fuehre hier Ihre Befehle aus."));
    $dir->vecho(knechtusage) if $dir->bell('help');
    my $line = shift;
    my ($item) = $line =~ m(\A(\w[\w/\.\-]*\w)\Z);
    my $relpaf = $item || join(".", $dir->bell('profil'), "txt");
    if ($dir->bell('mail')) { $dir->bellkv(auth=>1, gpg=>1, verb=>1); };
    @{$usr->{toplines}} = ();
    $usr->authinput if $dir->bell('auth');
    my @users = split(/[^\w]+/, shift || $dir->bell('users'));
    return $dir->aua(78, gettext("Mit wem, bitte, habe ich die Ehre?")) unless @users;
    $dir->decho("users: %s", commed(@users));
    my @passwds = split(/[^\w]+/, shift || $dir->bell('passwds'));
    $dir->decho("passwds: %s", commed(@passwds));
    for (qw/mail cryptpass uid udir/) { $usr->{$_} = ""; }
    $item = shift;
    $usr->{mail} = $item || $dir->bell('from') || "";
    $dir->UMask('umask');
    ($item) = $users[0] =~ m(\A([a-z]{3,8})\Z);
    return $dir->aua(34, gettext("Kennung %s besteht nicht aus 3-8 Buchstaben!"), $users[0]) unless $item;
    $usr->{uid} = $item;
    ($item) = $passwds[0] =~ m(\A(\w{5,12})\Z);
    return $dir->aua(33, gettext("ungeeignetes Passwort %s.\nDas Passwort muss 5-12 alphanumerische Zeichen enthalten."), $passwds[0]) unless $item or $dir->bell('adm');
    my $pw = $item;
    my $uid = $usr->{uid};	
    my $pwx;
    my ($u1, $u2) = (substr($uid, 0, 2), substr($uid, 2));
    return $dir->aua(32, gettext("uid '%s' split to directories '%s'."), $uid, "$u1/$u2") unless $u2;
    $usr->{udir} = dirslashed $dir->{homedir}, $u1, $u2;
    unless ($dir->bell('rdbonly')) {
	$dir->exek("mkdir -p %s", $usr->{udir}) unless $dir->bell('rdbonly') or -d $usr->{udir};
	$dir->aua(31, gettext("Neueinrichtung von %s verweigert"), $usr->{udir}) unless -d $usr->{udir} or $dir->bell('adm');
	my $passfile = dirslashed $usr->{udir}, ".pass";
	return $dir->aua(30, gettext("Türschloss kaputt")) unless -r $passfile or $dir->bell('adm');
	if (open FI, "<", $passfile) {
	    $line = <FI>;($item) = $line =~ m(\A(\S+)\s*\Z);$pwx = $item;
	    $line = <FI>;($item) = $line =~ m(\A(\S+\@\S+)\s*\Z);
	    $usr->{mail} = $item || $usr->{mail};
	    close FI;  
	    $usr->sqlputpw($pwx); 
	} };
    $pwx = $dir->sqlgetpw($usr->{uid}); 
    my $crypt = crypt $pw, $pwx;
    $dir->decho("\tVersuche Eintritt mit pw $pw, pwx $pwx, crypt $crypt");
    return $dir->aua(29, gettext("Falsches Passwort")) unless $dir->bell('adm') or ($pwx and ($crypt =~ /\A$pwx/));
    $dir->decho("\t\tGelungen.");

    $usr->setperms or return;

    if ($#users > 0) { $usr->chid($users[$#users]) or return; };
    if ($passwds[$#passwds] and ($#passwds > 0 or not $pwx)) { $usr->chpw($passwds[$#passwds]) or return; };
    
    my ($reldir, $relbas);
    for ($relpaf) {
	($reldir, $relbas) = m((.*/)?(\w+)[^/]*);
	@{$usr->{lkeys}} = split /[^\w]+/, $usr->perm('lkeys', $relbas);
	@{$usr->{lvals}} = map { $usr->{$_} } @{$usr->{lkeys}}; 
	$dir->decho("RELBAS: %s; LKEYS: %s; LVALS: %s\n", $relbas, commed(@{$usr->{lkeys}}), commed(@{$usr->{lvals}}));
    };

    $usr->{abspaf} = dirslashed $usr->{udir}, $relpaf;
    $usr->{absdir} = dirslashed $usr->{udir}, $reldir;
    for ($usr->{absdir}) { system "mkdir -p $_" unless -d $_ };
    my ($lang) = $dir->bell('locale') =~ /^(\w\w)/;
    for ($lang, "en", $lang) {
 	$usr->{frmpaf} = dirslashed $dir->{frmbas}, "profil", join(".", $dir->bell('profil'), $_, "txt");
	last if -r $usr->{frmpaf};
    };
    $dir->decho("\tI will use template file %s",$usr->{frmpaf});
    $usr->{log}{dir} = dirslashed($usr->{udir}, ".log");
    # for ($usr->{log}{dir}) { do { unlink $_ if -f $_;system "mkdir -p $_" } unless -d $_ };
    $usr->{log}{file} = dirslashed($usr->{log}{dir}, sprintf("%02d%02d", $dir->{dies}{jar}, $dir->{dies}{mon}));
    $usr->file2user($usr->{abspaf}) if not $dir->bell('rdbonly');
    $usr->args2user("sid", "val", join('', (0..9, 'A'..'Z', 'a'..'z')[rand 62, rand 62, rand 62, rand 62, rand 62, rand 62, rand 62, rand 62, rand 62, rand 62, rand 62, rand 62])) if $dir->bell('sid');
    $usr->psql2user("epat", "repr");
    # $usr->initepat;
    # $usr->initrepr;
    $usr->{done}{rec2text} = ();
    # $dir->decho(Dumper($usr)) if $dir->bell('debug');
    $dir->decho("NEWUSER finito");
    return $usr;
}

sub psql2user {
    my ($usr, $dir) = verusr(shift) or return;
    my ($tab, $nr, $nf, $str, $key, $lkey, $rkey, @lkeys, @rkeys, @kvals, @row);
    my @uidtabs = $dir->uidtabs;
    my @tabs = @_ ? grep { $_ } map { grep { $_ } @uidtabs && $_ } @_ : @uidtabs;
    $dir->decho("PSQL2USER %s\nread from PostgreSQL database tables into USER data array", commed(@tabs));
    return unless $dir->verdb;
    foreach $tab (@tabs) {
	@kvals = $usr->kvals($tab);
	@lkeys = @{$dir->{vdefs}{$tab}{lkeys}};
	@rkeys = @{$dir->{vdefs}{$tab}{rkeys}};
	$dir->decho("\ttab: %s, lkeys: %s; rkeys: %s; kvals: %s", $tab, commed(@lkeys), commed(@rkeys), commed(@kvals));
	$nr = 0;$str = join(" and ", map { sprintf("%s = '%s'", $lkeys[$nr++], $_); } @kvals);
	$str = spaced(sprintf("select %s from %s", commed(@lkeys, @rkeys), $tab), $str ? "where $str" : "");
	my @records = $dir->{pgdb}{ffii}->get_records($str);
	$dir->decho("%d records", scalar @records);
	foreach $record (@records) {
	    @row = @$record;
	    $lkey = tabbed($tab, @row[$#kvals+1..$#lkeys]);
	    $nf = $#lkeys;
	    $dir->decho("row: %s\nnkvals: %d\nusr data for lkey $lkey", commed(@row), $#kvals);
	    foreach $rkey (@rkeys) { 
		$dir->decho("\twith rkey %s before reading:\t%s", $rkey, $usr->{data}{$lkey}{$rkey});
		$usr->{data}{$lkey}{$rkey} = $row[++$nf]; 
		$dir->decho("\twith rkey %s after reading:\t%s", $rkey, $usr->{data}{$lkey}{$rkey});
	    };
	};
	$usr->{done}{psql2user}{$tab} = 1;
    };
}

sub checkpermgrants {
    my ($usr, $dir) = verusr(shift) or return;
    $dir->decho("CHECKPERMGRANTS");
    return 1 if $usr->{perm}{perm};
    my ($perm, $key, $val);
    local $_;
  PERMS: foreach $key (keys %{$usr->{data}{perm}}) {
      $perm = "perm";
    PERM: for (split /[^\w]+/, $key) {
	$perm = join("\t", $perm, $_);
	$val = $usr->{perm}{$perm};
	last if $val;
    };
      if ($val) 
      { $dir->decho("Recht $perm mit $val belegt. Gut."); }
      else 
      { $dir->aua(173, "Rechtevergabe %s nicht gestattet", $key);
	delete $usr->{data}{perm}{$key}; };
    };
    return 1;
};

sub movkey {
    # return non-null if movtab operation is completed, thus
    # enabling a nonlocal exit in the invoking function movtab
    my ($usr, $dir) = verusr(shift) or return;
    my ($rid, $tab) = @_;
    local $_;
    $dir->decho("\tMOVKEY $rid");
    return unless $rid;
    my ($key) = $rid =~ /\Amov\t(\w+)\Z/;
    $dir->decho("\t\tkey: $key");
    return unless $key;
    my ($kmd, @args) = untabbed $dir->{vdefs}{$tab}{$rid};
    $dir->decho("\t\tkmd: %s; args: %s", $kmd, commed @args);
    return unless $kmd and @args;
    my $val;
    for ($kmd) {
	/^key/ && do { $val = $usr->{k2v}{$args[0]};$dir->decho("\t\t$val");return unless defined $val;$usr->{k2v}{$key} = $val; };
	/^val/ && do { $usr->{k2v}{$key} = $args[0]; };
	/^rev/ && do { $usr->{k2v}{$key} = $args[1] if $usr->{k2v}{$key} =~ /\A$args[0]\Z/; } };
    $dir->decho("\t\tmov k2v of %s is %s", $key, $usr->{k2v}{$key}); 
    return 1;
};

sub movtab {
    my ($usr, $dir) = verusr(shift) or return;
    my $tab = shift;
    local $_;
    $dir->decho("MOVTAB $tab: move data of old table $tab to new verbdefs syntax if needed and return name of new table.");
    my $tab2 = $dir->{vdefs}{$tab}{mov};
    return $tab unless $tab2;
    $dir->decho("\ttable $tab will become table $tab2, now we look at the fields.");
    my @movkeys = grep /^mov\t/, keys %{$dir->{vdefs}{$tab}};
    $dir->decho("\tMOVKEYS of verb $tab are %s", commed @movkeys);
    my $key;foreach $key (@movkeys) { $usr->movkey($key, $tab) }; 
    return $tab2;
};

sub line2user {
    my ($usr, $dir) = verusr(shift) or return;my $line = shift;
    $dir->decho("LINE2USER");
    local $_;
    return unless $line;
    my ($i, $rid, $tab, $key, $rkey, $val, $rest, $sep, @keys, @vals, @lkeys, @kvals, @lvals, @rkeys, @rvals) = ();
    $usr->{k2v} = ();
    chomp($line);
    ($tab, $rest) = $line =~ m(\A(\S+)\s+(.+)\s*\Z);
    $dir->decho("\ttab: %s, rest: %s", $tab, $rest);
    return unless $tab and $rest;
    if ($tab =~ m(\Z(\w+)_(\w+)\Z)) { ($tab, $rkey) = ($1, $2) };
    return $dir->aua(187, gettext("unbekanntes Verb %s"), $tab) unless $dir->{vdefs}{$tab};
    return $dir->aua(186, gettext("unzureichend definiertes Verb %s"), $tab) unless $dir->{vdefs}{$tab}{lkeys} and $dir->{vdefs}{$tab}{rkeys};
    @lkeys = @{$dir->{vdefs}{$tab}{lkeys}};
    return $dir->aua(185, gettext("Keine Index-Felder fuer Verb %s bekannt"), $tab) unless @lkeys;
    @rkeys = ($rkey || @{$dir->{vdefs}{$tab}{rkeys}});
    return $dir->aua(184, gettext("Keine Wert-Felder fuer Verb %s bekannt")) unless @rkeys;
    @kvals = $usr->kvals($tab);
    $i=0;for (@kvals) { $key = $lkeys[$i];last unless $key;$usr->{k2v}{$key} = $_;$i++ };
    $dir->decho("\ttab: %s, lkeys: %s; rkeys: %s; kvals: %s", $tab, commed(@lkeys), commed(@rkeys), commed(@kvals));
    if ($line =~ m(\S+[ ]*([\t:\|]+)[ ]*\S))
    { $sep = $1;
      @vals = split /$sep/, $rest;
      $dir->decho("\tFeldtrenner '%s' in Zeile '%s' erzeugt Werte %s.", $sep, $line, vjoin("\n\t\t", @vals)); }
    else 
    { @vals = ();for $i ($#kvals+1 .. $#lkeys) {
	$rest =~ /\G\s*((?:"([^\"]*)")|(\S+))/g;  
	$dir->decho("\tLKeys-rexp 1: $1\n\t\tREST: $rest\n\t\t2: $2\n\t\t3: $3\n\t\t4: $4");
	$val = zor($2, $3);
	$dir->decho("\t\tval: $val");
	push @vals, $val; };
      $dir->decho("\tLeft VALS: %s", commed @vals);
      if ($rkey) 
      { $rest =~ /\G\s*((?:"([^\"]*)")|(.*))\s*/g;
	$dir->decho("\tRKey $rkey rexp\n\t\tREST: $rest\n\t\t1: $1\n\t\t2: $2\n\t\t3: $3\n\t\t4: $4");
	$val = zor($2, $3);
	push @vals, $val } 
      else 
      { $i = 0;
	while ($rest =~ /((?:"([^\"]*)")|(\w+)\s*=\s*((?:"([^\"]*)")|(\S*))|(\S+))\s*/g) {
	    $dir->decho("\tRKeys %s rexp:\n\t\trest: $rest\n\t\t1: $1\n\t\t2: $2\n\t\t3: $3\n\t\t4: $4\n\t\t5: $5\n\t\t6: $6\n\t\t7: $7\n\t\t8: $8", commed @rkeys);
	    $key = $3 || $rkeys[$i];
	    $val = zor($2, $5, $6, $7, "");
	    $dir->decho("\t\tnf: %d; key: %s; val: %s", $i, $key, $val);
	    last unless $key;
	    $usr->{k2v}{$key} = $val;
	    $i++; } } };
    @keys = (@lkeys, @rkeys);
    $i = $#kvals;for (@vals) { $i++;if (/^\s*(\w+)\s*=\s*(.+)\s*$/) { $key = $1;$usr->{k2v}{$key} = $2; } else { $key = $keys[$i];$usr->{k2v}{$key} = $usr->{k2v}{$key} || $_; };$dir->decho("\tk2v of %s is %s", $key, $usr->{k2v}{$key}); };
    @vals = map { $usr->{k2v}{$_} } @keys;
    $tab = $usr->movtab($tab);
    @lkeys = @{$dir->{vdefs}{$tab}{lkeys}};
    @rkeys = @{$dir->{vdefs}{$tab}{rkeys}};
    @keys = (@lkeys, @rkeys);
    @vals = map { $dir->decho("\t\tnew k2v of %s is %s", $_, $usr->{k2v}{$_});$usr->{k2v}{$_} } @keys;
    @lvals = @vals[$#kvals+1..$#lkeys];
    @rvals = @vals[$#lkeys+1..$#vals];
    ($rid) = tabbed($tab, @lvals) =~ /^(.*\S)\s*$/;
    foreach $i (0 .. $#rkeys) { $val = $rvals[$i];next unless defined $val;next if $val =~ /^[\.\?_-]$/;$key = $rkeys[$i];$dir->aua(137, gettext("kein Schluessel fuer Index %d gefunden"), $i) unless $key;$usr->{data}{$rid}{$key} = $dir->vtypchk($key, esc2ctl(trimquotes($val))); };
    return if $dir->{err}; # be strict on vtypchk
    $usr->checkpermgrants;
    $usr->{done}{args2user}{$rid} = 1;
    $dir->decho("LINE2USER finito: usr of %s has keys %s and values %s\n", $rid, commed(keys %{$usr->{data}{$rid}}), commed(values %{$usr->{data}{$rid}})); 
    return if $dir->{err};
    return 1;
}

sub blok2user {
    my ($usr, $dir) = verusr(shift);
    my ($line, @lines) = @_;
    my ($blok, $bloklim, $blokkod) = $line =~ m(\Abloc?k\s+(\w+)\s+(\S+)\s*(\w*)\Z);
    $dir->decho("BLOK2USER $blok, delimited by '$bloklim', armored with '$blokkod'");
    return unless $blok and $bloklim;
    $usr->{blok}{$blok}{lim} = $bloklim;
    $usr->{blok}{$blok}{kod} = $blokkod if $blokkod;
    while (@lines) { 
	$line = shift @lines;
	chomp($line);
	last if $line =~ m(\A$bloklim);
	$usr->{blok}{$blok}{txt} .= "$line\n";
    } 
    return $line, @lines; };

sub fld2text {
    my ($usr, $dir) = verusr(shift) or return;
    my ($rid, $key) = @_;
    local $_;
    $dir->decho("FLD2TEXT writing out field %s of record %s", $key, $rid);
    my $val = $usr->{data}{$rid}{$key};
    $dir->decho("\tRKEY: %s; RVAL: %s", $key, $val);
    return unless defined $val;
    my $ret = sprintf("%s = %s", $key, &ctl2esc($val));
    $dir->decho("FLD2TEXT RET: $ret");
    return $ret;
};

sub rec2text { 
    my ($usr, $dir) = verusr(shift) or return;
    my $rid = shift;
    $dir->decho("REC2TEXT writing out record %s", $rid);
    my ($tab, @lvals) = untabbed $rid;
    return unless $dir->vertab($tab);
    my @rkeys = @{$dir->{vdefs}{$tab}{rkeys}};
    return $dir->aua(47, gettext("keine Felddefinitionen fuer Tabelle %s gefunden"), $tab) unless @rkeys;
    $dir->decho("REC2TEXT RID: %s; TAB: %s; RKEYS: %s", $rid, $tab, commed(@rkeys));
    $usr->{done}{rec2text}{$rid} = 1;
    my $rkey;
    my $ret = tabbed $rid, map { $rkey = $_;$usr->fld2text($rid, $rkey) } @rkeys; 
    $dir->decho("REC2TEXT RET: $ret");
    return $ret;
}

sub tab2text {
    my ($usr, $dir) = verusr(shift) or return;
    my $ridtab = shift;
    my $rid;
    $dir->decho(gjoin(" ", "TAB2TEXT write remaining records", $ridtab && "matching $ridtab"));
    my @rids = grep { $rid = $_;not $usr->{done}{rec2text}{$rid} } keys %{$usr->{data}};
    $dir->decho("\trecords to choose from: %s\n\t\t%s", join("\n\t\t", @rids));
    if ($ridtab) {
	@rids = grep /\A$ridtab\b/, @rids;
	$dir->decho("\trecords selected by %s:\n\t\t%s", $ridtab, join("\n\t\t", @rids));
    };
    my @lines = map { $rid = $_;$usr->rec2text($rid) } @rids;
    my $ret = lined(@lines);
    $dir->decho("TAB2TEXT RET: %s\n", $ret);
    return $ret;
}

sub id2rows {
    my ($usr, $dir) = verusr(shift) or return;
    my ($rid, @rkeys) = @_;
    my ($tab, @lvals) = untabbed $rid;
    local $_;
    $dir->decho("ID2ROWS %s %s", $tab, commed @lvals);
    $dir->vertab($tab) or return;
    @rkeys = @{$dir->{vdefs}{$tab}{rkeys}} unless @rkeys;
    $dir->decho("id2rows tab: %s; lvals: %s; rkeys: %s", $tab, commed(@lvals), commed(@rkeys));
    return unless @rkeys;
    my ($key, $val);
    return map { $key = $_;$val = $usr->{data}{$rid}{$key};defined $val ? [ $tab, @lvals, $key, $val ] : undef; } @rkeys;
}

sub kvals {
    my ($usr, $dir) = verusr(shift) or return;
    my $tab = shift;
    my (@objflds) = @{$usr->{lkeys}};
    my (@objvals) = @{$usr->{lvals}};
    my (@tabflds) = @{$dir->{vdefs}{$tab}{lkeys}};
    my ($fof, $faf, $fav, $fov, @kvals);
    $dir->decho("KVALS $tab: objflds @objflds; objvals @objvals; tabflds @tabflds");
    while ($fof = shift @objflds and $faf = shift @tabflds and $fof =~ /^$faf$/)
    { $fov = shift @objvals;
      push @kvals, $fov };
    $dir->decho("KVALS of %s is %s.", $tab, commed(@kvals) || "unknown");
    return @kvals;
}

sub usel2rows {
    my ($usr, $dir) = verusr(shift) or return;
    my ($tab, @vals) = @_;
    local $_;
    $dir->decho("USEL2ROWS: %s", commed($tab, @vals));
    $dir->vertab($tab) or return;
    $usr->psql2user($tab) unless $usr->{done}{psql2user}{$tab};
    my @rids = keys %{$usr->{data}};
    return $dir->aua(48, gettext("keine Eintraege gefunden")) unless @rids;
    my @lkeys = @{$dir->{vdefs}{$tab}{lkeys}};
    my @kvals = $usr->kvals($tab);
    @vals = (@kvals, @vals);
    my @lvals = @vals[0..$#lkeys];
    my @rkeys = @vals[$#lkeys+1..$#vals];
    @rkeys = @{$dir->{vdefs}{$tab}{rkeys}} unless @rkeys;
    $dir->decho("\t\ttab: %s\n\t\tvals: %s\n\t\tlkeys: %s\n\t\tlvals: %s\n\t\t rkeys: %s", $tab, commed(@vals), commed(@lkeys), commed(@lvals), commed(@rkeys)); 
    my $line = tabbed($tab, @vals[$#kvals+1..$#lvals]); 
    my ($ridtab) = $line =~ m(\A(.*\S)\s*\Z);
    @rids = grep /\A$ridtab\b/, @rids; 
    $dir->decho("\tRIDTAB and RIDS\n\t\ttabsel: %s\n\t\trids: %s", $ridtab, commed(@rids));
    return grep { $_ } map { $usr->id2rows($_, @rkeys) } @rids;
}

sub usel2val {
    my ($usr, $dir) = verusr(shift) or return;
    $dir->decho("USEL2VAL: %s", commed(@_));
    $usr->psql2user($_[0]) unless $usr->{done}{psql2user}{$_[0]};
    return $usr->{data}{coltabbed(@_[0..$#_-1])}{$_[$#_]};
};


sub usel2text {
    my ($usr, $dir) = verusr(shift) or return;
    my $ridtab = shift;
    $dir->decho("USEL2TEXT ridtab: $ridtab"); 
    my ($tab, @vals) = split /\s+/, $ridtab;
    if ($tab =~ /(\w+)_(\w+)/) { $tab = $1;push @vals, $2; };
    return rows2text($usr->usel2rows($tab, @vals));
}

sub args2user {
    my ($usr, $dir) = verusr(shift) or return;
    my ($tab, @vals) = @_;
    local $_;
    $dir->decho("ARGS2USER %s: %s", $tab, commed(@vals));
    $dir->vertab($tab) or return;
    $usr->psql2user($tab) unless $usr->{done}{psql2user}{$tab};
    my @lkeys = @{$dir->{vdefs}{$tab}{lkeys}};
    my @rkeys = @{$dir->{vdefs}{$tab}{rkeys}};
    my @lvals = @vals[0..$#lkeys-1];
    my $rid = tabbed($tab, @lvals);
    my @rvals = @vals[$#lkeys..$#vals];
    my ($nk, $nv, $key, $val) = (0, 0);
    while ($nk <= $#rkeys and $nv <= $#rvals) {
	$key = $rvals[$nv++];
	if ($key) {
	    return $dir->aua(45, gettext("Tabelle %s enthaelt kein Feld namens %s."), $tab, $key) unless grep /^$key$/, @rkeys;
	} else { $key = $rkeys[$nk] };
	return $dir->aua(44, gettext("Tabelle %s hat nicht genug Felder fuer die uebergebenen Werte."), $tab) unless $key;
	$val = $rvals[$nv];
	$dir->decho("\trvals of %d is $val", $nv);
	next unless defined $val;
	$usr->{data}{$rid}{$key} = $val;
    } continue { $nk++;$nv++; }; 
    $usr->{done}{args2user}{$rid} = 1;
    return 1;
}

sub delargs {
    my ($usr, $dir) = verusr(shift) or return;
    my ($tab, @vals) = @_;
    my ($i);
    local $_;
    $dir->decho("DELARGS: %s", commed($tab, @vals));
    $dir->vertab($tab) or return;
    my @lkeys = @{$dir->{vdefs}{$tab}{lkeys}};
    my @lvals = @vals[0..$#lkeys-1];
    my $rid = tabbed($tab, @lvals);
    delete $usr->{data}{$rid};
    return unless $dir->verdb;
    my ($key, $val);
    $dir->{pgdb}{ffii}->query(sprintf(qq{delete from %s where %s}, $tab, vjoin(" and ", map { $val = $_;$key = $lkeys[$i++];sprintf("%s = %s", $key, squoted($val)); } ($usr->kvals($tab), @lvals))));
    return 1;
}

sub blok2psql {
    my ($usr, $dir) = verusr(shift);
    my $blok = shift or return;
    my $bloktxt = $usr->{blok}{$blok}{txt};
    my $blokkod = $usr->{blok}{$blok}{kod};
    my $uid = $usr->{uid};
    return $dir->{pgdb}{ffii}->edit('blok', { uid=>$uid, blok=>$blok}, bloktxt=>$bloktxt, blokkod=>$blokkod);
}

sub rid2psql { 
    my ($usr, $dir) = verusr(shift) or return; 
    my $rid = shift;
    my ($i);
    local $_;
    $dir->decho("RID2PSQL: update/insert record %s", $rid);
    next unless $rid;
    my ($tab, @lvals) = untabbed $rid;
    $dir->vertab($tab) or return;
    $dir->decho("\ttab: %s\n\tlvals: %s\tkeys: %s\n\tvals: %s", $tab, colcommed(@lvals), colcommed(keys %{$usr->{data}{$rid}}), colcommed(values %{$usr->{data}{$rid}}));
    return if $dir->{vdefs}{$tab}{nodb};
    my @lkeys = @{$dir->{vdefs}{$tab}{lkeys}};
    return unless @lkeys;
    @lvals = ($usr->kvals($tab), @lvals);
    return unless @lvals;
    my @rkeys = @{$dir->{vdefs}{$tab}{rkeys}};
    return unless @rkeys;
    my @rvals = map { $usr->{data}{$rid}{$_} } @rkeys;
    return unless @rvals;
    $dir->decho("\ttab: %s; lkeys: %s; lvals: %s; rkeys: %s, rvals: %s", $tab, commed(@lkeys), commed(@lvals), commed(@rkeys), commed(@rvals));
    $usr->{done}{args2user}{$rid} = undef;
    my $rows = $dir->{pgdb}{ffii}->query(sprintf("update %s set %s where %s", $tab, commed(map { $i = $_;my ($key, $val) = ($rkeys[$i], $rvals[$i]);defined $val ? join(" = ", $key, squoted($val)) : undef;  } 0..$#rvals), vjoin(" and ", map { $i = $_;my ($key, $val) = ($lkeys[$i], $lvals[$i]);defined $val ? join(" = ", $key, squoted($val)) : undef; } 0 .. $#lkeys)));
    return 1 if $rows > 0;
    my @vals = (@lvals, @rvals);
    my @keys = (@lkeys, @rkeys);
    my (@ikeys, @ivals) = (); 
    for ($i=0; $i <= $#vals; $i++) { if (defined $keys[$i] and defined $vals[$i]) { push @ikeys, $keys[$i];push @ivals, $vals[$i]; }; };
    my $str = sprintf("insert into %s ( %s ) values ( %s )", $tab, commed(@ikeys), sqcommed(@ivals)); 
    $dir->{pgdb}{ffii}->query($str);
    $dir->decho("RID2PSQL finito");
    return 1;
}

# relation which contains primary key
my $ridtab1 = "pnom";
sub user2psql {
    my ($usr, $dir) = verusr(shift) or return;
    local $_;
    $dir->decho("USER2PSQL");
    my $ridtab = shift;
    $dir->decho("\twriting out ridtab $ridtab") if $ridtab;
    return if $dir->bell('txtonly');
    return unless $usr->perm('psql');
    return unless $dir->verdb;
    my (@rids) = ();
    # @rids = keys %{$usr->{data}};
    @rids = keys %{$usr->{done}{args2user}};
    if ($ridtab) 
    { @rids = grep /^$ridtab$/, @rids; }
    else { @rids = (grep(/\A$ridtab1\b/, @rids), grep(!/\A$ridtab1\b/, @rids)); };
    $dir->decho("USER2PSQL records: %s", join("\n\t", @rids));
    for (@rids) { $usr->rid2psql($_) or return };
    for (keys %{$usr->{blok}}) { $usr->blok2psql($_); };
    $dir->decho("USER2PSQL finito");
    return 1;
}

sub blok2text {
    my ($usr, $dir) = verusr(shift) or return;
    my $blok = shift;
    local $_;
    $dir->decho("blok2text $blok: return contents of blok $blok");
    return unless $blok;
    my $rid = tabbed("blok", $blok);
    $dir->decho("\tBID: $blok, RID: $rid");
    return if $usr->{done}{rec2text}{$rid}; 
    my $bloktxt = $usr->{blok}{$blok}{txt};
    return unless defined $bloktxt;
    chomp $bloktxt;
    my $bloklim = $usr->{blok}{$blok}{lim};
    return unless $bloklim; 
    $usr->{done}{rec2text}{$rid} = 1;
    my $text = lined spaced("blok", $blok, $bloklim, $usr->{blok}{$blok}{kod}), $bloktxt, $bloklim; 
    $dir->decho("blok2text result: $text");
    return $text;
}

sub bloks2text {
    my ($usr, $dir) = verusr(shift) or return;
    local $_;
    $dir->decho("bloks2text");
    my @bids = keys %{$usr->{blok}};
    $dir->decho("\tblok ids %s", commed(@bids));
    my $text = dlined map { $usr->blok2text } @bids; 
    $dir->decho("bloks2text result: $text");
    return $text;
}

sub flushdeleted {
    my ($usr, $dir) = verusr(shift) or return;
    local $_;
    $dir->decho("FLUSHDELETED");
    for (keys %{$usr->{data}}) {
	if (/\Arepr/ and $usr->{data}{$_}{replvl} and $usr->{data}{$_}{replvl} < 0) {
	    $dir->decho("flushing %s with replvl %d", $_, $usr->{data}{$_}{replvl});
	    delete $usr->{data}{$_}; }
	elsif (/\Aepat/ and $usr->{data}{$_}{deal} and $usr->{data}{$_}{deal} < 0) {
	    $dir->decho("flushing %s with deal %d", $_, $usr->{data}{$_}{deal});
	    delete $usr->{data}{$_}; };
    };
    return 1;
};

sub text2user {
    my ($usr, $dir) = verusr(shift) or return;
    my @lines = @_;
    local $_;
    $dir->decho("TEXT2USER: %d lines", $#lines+1);
    my ($line, $nextline, $i);
    while (@lines) {
	$line = shift @lines;
	$dir->decho("TEXT2USER line %d: %s", ++$i, $line);
	if ($line =~ m(\Abloc?k\b)) 
	{ ($line, @lines) = $usr->blok2user($line, @lines); }
	elsif ($line =~ m(\A(\w\w.*\s+.*\S)\Z)) # untaint and filter out verbs without args
	{ $usr->line2user($1);return if $dir->{err}; } }
    $dir->decho("TEXT2USER finito");
    return 1;
}

sub file2user {
    my ($usr, $dir) = verusr(shift) or return;
    my $file = shift;
    $dir->decho("FILE2USER $file");
    $usr->text2user($usr->flines($file));
    return if $dir->{err};
    $dir->decho("FILE2USER $file finito");
    return 1;
}

sub uval2text {
    my ($usr, $dir) = verusr(shift) or return;
    my @vars = @_;
    @vars = grep /^\w/, @vars;
    $dir->decho("UVAL2TEXT vars: %s\n", commed(@vars));
    my ($key);
    return lined map { $key = $_;$dir->decho("UVAL KEY %s", $key);$usr->usel2text($key); } @vars;  
}

sub profil_i2o {
    my ($usr, $dir) = verusr(shift) or return;
    my @ilines = @_;
    local $_;
    $dir->decho("PROFIL_I2O read %d input lines", $#ilines+1);
    my ($tab, $line, $text, @olines) = ();
    while (@ilines)
    { $line = shift @ilines;
      if (($tab) = $line =~ m(\A\#\#(\w+)\b)) 
      { while ($line =~ /^\#\#/)
	{ push @olines, $line;
	  last unless @ilines;
	  $line = shift @ilines; };
	$text = $usr->tab2text($tab);
	push @olines, "", $text, "" if $text; 
    };
      push @olines, $line; };
    $dir->decho("PROFIL_I2O return %d output lines", $#olines+1);
    return @olines;
}

sub user2file {
    my ($usr, $dir) = verusr(shift) or return;
    local $_;
    $dir->decho("USER2FILE");
    my $fi = shift || $usr->{frmpaf};
    my $fo = shift || $usr->{abspaf};
    
    $dir->bell('dummy') && do 
    { $fo = "$fo.out";
      $dir->decho("\tFI: %s", $fi);
      $dir->decho("\tFO: %s", $fo);
      }; 

    unlink $fo if -f $fo; # let umask take effect
    open FO, ">", $fo or return $dir->aua(21, gettext("kann nicht in Datei %s schreiben"), $fo);
    binmode FO, ":utf8" if $UTF8;
      
    my @olines = ();
    if ($fi && -r $fi && open FI, "<$fi") 
    { binmode FI, ":utf8" if $UTF8;
      my @ilines = map { chomp;$_ } <FI>;close FI;
      @olines = $usr->profil_i2o(@ilines); }
    else { $dir->vecho("Konnte Datei %s nicht lesen.  Es geht auch gut ohne Vorlage.", $fi); };

    my $text = $usr->tab2text;
    push @olines, "", $text if $text;
    $text = $usr->bloks2text;
    push @olines, "", $text if $text;
    print FO lined @olines;
    close FO;
    $usr->{done}{rec2text} = ();
    chmod oct('660'), $fo;
    $dir->decho("USER2FILE finito");
    return 1;
}

sub initrepr {
    my ($usr, $dir) = verusr(shift) or return;
    $dir->decho("INITREPR initiate a representative");
    # $usr->psql2user("repr");
    my @meps  = grep /\Arepr\tmep\b/, keys %{$usr->{data}};
    $dir->decho("\t%d meps", $#meps+1);
    return @meps if @meps;
    my $mep = $usr->pickmep;
    return unless $mep;
    $usr->args2user("repr", "mep", $mep, replvl=>0);
    return $mep;
}

sub initepat {
    my ($usr, $dir) = verusr(shift) or return;
    $dir->decho("INITEPAT iniciigu e-patentojn");
    # $usr->psql2user("epat");
    my @pats  = grep /\Aepat\b/, keys %{$usr->{data}};
    $dir->decho("\t%d pats", $#pats+1);
    return @pats if @pats;
    my $pat = $usr->pickpat;
    return unless $pat;
    $usr->args2user("epat", $pat, tech=>0);
    return $pat;
}

sub patdirs {
    my $dir = verdir(shift) or return;
    my $str = shift;
    my ($land, $num) = $str =~ /\A(\w\w)([\d\s\,\.]+)\Z/;
    return $dir->aua(107, gettext("ungueltige Patentkennung %s"), $str) unless $num;
    $land = lc($land);
    $num =~ s/[\s\,\.]//g;
    ($num) =~ m(\A(\d{1,8})\Z);
    return $dir->aua(106, gettext("keine Patentnummer in %s gefunden"), $str) unless $num; 
    $land = lc($land); 
    $land =~ /ep/ && return "ep", sprintf("%04d", $num/1000), sprintf("%03d", $num%1000);
    $land =~ /de/ && return "de", sprintf("%02d", $num/1000000), sprintf("%03d", ($num%100)/1000), sprintf("%03d", $num%(100*1000)); 
    return $dir->aua(105, gettext("Mit dem Patentamt %s kenne ich mich nicht aus."), $land);
}

sub patid {
    my $dir = verdir(shift) or return;
    my $str = shift;
    my @patdirs = $dir->patdirs($str);
    return vjoin("", @patdirs) if @patdirs;
}

sub paturl {
    my $dir = verdir(shift) or return;
    my $pat = shift;
    my @patdirs = $dir->patdirs($pat);
    return dirslashed "http://swpat.ffii.org", "pikta", "txt", @patdirs;
}
sub pattxturl {
    my $dir = verdir(shift) or return;
    my $pat = shift;
    my @patdirs = $dir->patdirs($pat);
    return dirslashed "http://swpat.ffii.org", "pikta", "txt", @patdirs, join(".", $pat, "txt");
}
sub patpafdir {
    my $dir = verdir(shift) or return;
    my ($pat, $imgp) = shift;
    my @patdirs = $dir->patdirs($pat);
    return dirslashed $dir->{patdir}, $imgp ? "img" : "txt", @patdirs;
}
sub pattxtdir { my $dir = shift;my $pat = shift;$dir->patpafdir($pat); } 
sub patimgdir { my $dir = shift;my $pat = shift;$dir->patpafdir($pat, 1); } 

sub patpaf {
    my $dir = verdir(shift) or return;
    my ($pat, $imgp) = shift;
    my @patdirs = $dir->patdirs($pat);
    return dirslashed $dir->{patdir}, $imgp ? "img" : "txt", @patdirs, join(".", $pat, $imgp ? "pdf" : "txt");
}
sub pattxtpaf {
    my ($dir, $pat) = @_;
    return $dir->patpaf($pat);
}
sub patimgpaf {
    my ($dir, $pat) = @_;
    return $dir->patpaf($pat, 1);
}

sub patimg {
    my $dir = verdir(shift) or return;
    my $str = shift;
    my @patdirs = $dir->patdirs($str);
    return dirslashed $dir->{pafbas}, "swpat", "pikta", "img", @patdirs;
}

sub user2disk { 
    my ($usr, $dir) = verusr(shift) or return;
    local $_;
    $dir->decho("USER2DISK");
    $usr->flushdeleted;
    $usr->user2file if not $dir->bell('rdbonly');
    $usr->user2psql if not $dir->bell('txtonly'); 
    $usr->logprint('norm', sprintf("pag\tsum=%s\tmon=%s\tbeg=%s\tfin=%s", $usr->{data}{pag}{pagsum}, $usr->{data}{pag}{pagmon}, $usr->{data}{pag}{pagbeg}, $usr->{data}{pag}{pagfin})); 
    $dir->decho("USER2DISK finito");
    return 1;
}

sub text2file {
    my ($usr, $dir) = verusr(shift) or return;
    my ($fi, $fo, @lines) = @_;
    $dir->bell('debug') && do 
    { $fo = "$fo.out";
      printf STDERR "TEXT2FILE FI: %s\n", $fi;
      printf STDERR "TEXT2FILE FO: %s\n", $fo;
      printf STDERR "TEXT2FILE LINES: %s\n", tabbed(@lines); 
      }; 

    $usr->text2user(@lines);
    $usr->user2file($fi, $fo);
    $dir->decho("TEXT2FILE finito");
}

sub extractkeys {
    my ($usr, $dir) = verusr(shift) or return;
    my $abspaf = $usr->{abspaf};
    my $keyspaf = dirslashed $usr->{udir}, "pubkeys.txt";
    local $_;
    open FI, "<", $abspaf;
    open FO, ">", $keyspaf;
    my $line;
    while ($line = <FI>)
    { if ($line =~ m(-----BEGIN PGP PUBLIC KEY BLOCK-----))
      { print FO "-----BEGIN PGP PUBLIC KEY BLOCK-----\n";
        while ($line = <FI>)
	{ if ($line =~ m(-----END PGP PUBLIC KEY BLOCK-----))
	  { print FO "-----END PGP PUBLIC KEY BLOCK-----\n";last }
	  else { print FO $line };
      } } }
    close FO;
    close FI;
    $dir->exek("gpg --import $keyspaf");
    $usr->{sign} = $dir->exek("gpg --verify $abspaf");
}

sub loglvl {
    my $dir = shift;
    my $loglvl = $dir->bell('log');return $loglvl if $loglvl;
    return $LOGLEVELS{debug} if $dir->bell('debug');
    return $LOGLEVELS{verb} if $dir->bell('verb');
    return $LOGLEVELS{norm};
};

sub logprint {
    my ($usr, $dir) = verusr(shift) or return;
    my ($msgtyp, @msgs) = @_;
    local $_;
    $dir->decho("LOGPRINT: lnom: %s; snum: %s; sign: %s; dir: %s; file: %s, msgs: %s\n", $msgtyp, $LOGLEVELS{$msgtyp}, $LOGLEVELS{sign}, $usr->{log}{dir}, $usr->{log}{file}, commed(@msgs));
    my $msglvl = zor($LOGLEVELS{$msgtyp}, $LOGLEVELS{norm}) || 0;
    my $loglvl = $dir->loglvl;
    return if $msglvl > $loglvl;
    return if $loglvl <= $LOGLEVELS{sign} and not $usr->{sign};
    printf FLOG "%s: %s\n", spaced($dir->dirtimestamp, $usr->{sign} && "sign", $usr->{krypt} && "krypt"), vjoin("; ", map { chomp;$_ } @msgs);
    do {
	$dir->{pgdb}{ffii}->query(sprintf(qq{insert into knechtlog (uid, msg) values ('%s', '%s')}, $usr->{uid}, vjoin("; ", @msgs)));
	return if $dir->lasterror }
    unless $dir->bell('txtonly');
    return 1
}

sub untarpack {
    my ($usr, $dir) = verusr(shift) or return;
    my ($file, $wdir, $armor, $tarzip) = @_;
    $dir->decho("UNTARPACK %s", commed(@_));
    return $dir->aua(46, gettext("Datei %s nicht lesbar"), $file) unless -r $file;
    return unless $dir->exekaua(68, "%s %s | tar -xp %s -f -", $armor =~ /uu/ ? "uudecode -o /dev/stdout" : "mimencode -u", $file, gjoin(" ", vjoin(" ", "-C", $wdir), $dir->{tarX} ? spaced("-X", $dir->{tarX}) : "--exclude='.*'", $dir->bell('verb') && "-v", do { if ($tarzip =~ m(tbz)) { "-j" } elsif ($tarzip =~ m(tgz)) { "-z" } }));
    return 1;
}

sub tarpack {
    my ($usr, $dir) = verusr(shift) or return;
    my ($file, $wdir, $armor, $tarzip) = @_;
    return unless $dir->exekaua(18, "tar -cp %s -f - | %s %s", gjoin(" ", vjoin(" ", "-C", $usr->{udir}), $dir->{tarX} ? "-X $dir->{tarX}" : "--exclude='.*'", $dir->bell('verb') && "-v", do { if ($tarzip =~ /tbz/) { "-j" } elsif ($tarzip =~ /tgz/) { "-z" } }), $armor =~ /uu/ ? "uuencode" : "mimencode", $file); 
    return 1;
}

sub upload {
    my ($usr, $dir) = verusr(shift) or return;
    my ($file, $wdir, @lines) = @_;
    local $_;
    $dir->decho("UPLOAD $file $#lines");
    my $fo = "$file.out";
    open FO, ">", $fo or return $dir->aua(21, gettext("kann nicht in Datei %s schreiben"), $fo);
    binmode FO, ":utf8" if $UTF8;
    for (@lines) { chomp;print FO "$_\n" };
    close FO;
    if (-f $file) { unlink $file or return $dir->aua(22, "konnte alte Datei %s nicht loeschen", $file) };
    rename $fo, $file or return $dir->aua(21, "konnte Datei %s nicht zu %s umbenennen", "$file.out", $file);
    my $mode = "0660";chmod oct($mode), $file or return $dir->aua(20, gettext("Konnte Rechte von Datei %s nicht auf %s setzen.", $file, $mode));
    $dir->vecho(gettext("%s geschrieben und mit Erlaubnissen %s versehen."), $file, $mode);
    my ($recode);
    if ($file =~ /\.(tar|tgz|tbz)\.(uu|b64)$/) { $usr->untarpack($file, $wdir, $2, $1) }
    else
    { for ($dir->bell('cs')) {
	(not $_ or /utf-8|ascii/) && do { $dir->vecho(gettext("Nichts umzukodieren.  Gut so."));last };
	/iso-?8859|iso-?2022|latin|utf-16|euc|big5|jis/ && do { $recode = 1;last };
	/(tar|tgz|tbz)(uu|b64)/ && do { $dir->untarpack($file, $wdir, $2, $1); last }; #deprec
	return $dir->aua(41, gettext("unbekannte Kodierung %s"), $_); } } 
    if ($file =~ /profil\.txt$/)
    { $usr->extractkeys;
      $dir->exek(sprintf("cp -vf %s %s/profil.%s", $file, $usr->{log}{dir}, $dir->dirtimestamp)) if -d $_ and $usr->{sign};
      $dir->exek(sprintf("recode %s..utf-8 %s", $dir->bell('cs'), $file)) if $recode and not $usr->{sign}; };
    $dir->decho("upload finito");
    return 1;
};

sub servus {
    my ($usr, $dir) = verusr(shift) or return;
    $usr->args2user("asoc", asolvl=>-1);$usr->user2disk;
}

sub uidtabs {
    my $dir = verdir(shift) or return;
    return grep { $_ } map { (not $dir->{vdefs}{$_}{nodb}) && ((not $dir->{vdefs}{$_}{mov}) or ($dir->{vdefs}{$_}{mov} =~ /\A$_\Z/)) && $dir->{vdefs}{$_}{lkeys} && (grep /^uid$/, @{$dir->{vdefs}{$_}{lkeys}}) && $_ } keys %{$dir->{vdefs}};
}

sub deluid {
    my ($usr, $dir) = verusr(shift) or return;
    local $_;
    $dir->decho("DELUID");
    return $dir->aua(30, gettext("Das darf nur der Administrator")) unless $dir->bell('adm');
    my @uidtabs = $dir->uidtabs;
    for (@uidtabs) { $dir->{pgdb}{ffii}->delete($_, { uid=>$usr->{uid} }) };
    # $dir->exek("rm -rf %s", $usr->{log}{dir});   # system(rm -rf) seems not to work on subdirectories 
    unless ($dir->bell('rdbonly')) {
	$dir->exek("rm -rf %s", $usr->{udir});
	return $dir->aua(71, gettext("Verzeichnis %s existiert immer noch"), $usr->{udir}) if -d $usr->{udir};
    };
    return 1;
}

sub dabei {
    my ($usr, $dir) = verusr(shift) or return;
    my ($kmd, $file, @args) = @_;
    local $_;
    $dir->decho("DABEI");
    my $wdir = $usr->{udir};
    for ($file) {
	/^[\.\_\-\=pP]?$/ && do { $file = $usr->{abspaf};last };
	m(\A/(\w+)/(\w[\w\-\_\.\/]*\w)\Z) && do { $wdir = $usr->perm("wdir", $1);return $dir->aua(25, gettext("unbekanntes Arbeitsverzeichnis %s"), $wdir) unless $wdir;$file = dirslashed $wdir, $2;last };
	/^(\w[\w\-\_\.\/]*\w)$/ && do { $file = dirslashed $wdir, $1;last };
	return $dir->aua(25, gettext("Dateinamen wie %s akzeptiere ich nicht."), $_);
    };
    $dir->decho("\t%s %s %s", $kmd, $file, vjoin("\n\t", @args)); 
    return 1 unless $kmd;
    my ($text);
    for ($kmd) {
	/^(get|her|download)$/ && do 
	{ return $dir->aua(24, gettext("Keine Textdatei %s gefunden."), $file) unless -r $file and -T $file;
	  if ($file =~ /\.(tar|tgz|tbz)\.(uu|b64)$/) { $usr->tarpack($file, $wdir, $2, $1) };
	  if (open FI, "<", $file) { local $/ = undef;$text = <FI>;close FI;return $text }
	  else { return $dir->aua(23, gettext("Konnte Textdatei %s nicht lesen."), $file) };last };
	/^(getvals|werteher)$/ && do { return $usr->uval2text($usr->ilines(@args));last };
	/^putvals$/ && do { $usr->text2user($usr->ilines(@args));$usr->user2disk;last };
	/^rewrite$/ && do { $usr->user2disk;last };
	/^servus$/ && do { $usr->servus;last };
	/^(del|entf)$/ && do { $dir->exek("rm -fr $file");last };
	/^(hid|sperr)$/ && do { $dir->exek("chmod o-r $file") if -f $file;last };
	/^(pub|zeig)$/ && do { $dir->exek("chmod a+rX $file") if -f $file;last };
	/^(put|hin|upload|insnetz)$/ && do { $usr->upload($file, $wdir, $usr->ilines(@args));last };
	/^(upgr|aufr)/ && do { $usr->user2disk;last };
	return $dir->aua(19, "%s ?\n\t%s", $_, gettext("Wie bitte?")); }
    $dir->decho("dabei finito");
    return;
}

##package MEPS

my @MEPSTABS = ( "pnom", "land", "euprt", "naprt", "komit", "deleg", "adreu", "adrna", "fax", "fon", "mail", "http" );

sub mep2rows {
    my $dir = verdir(shift) or return;
    return if $dir->bell('nosql');
    return unless $dir->verdb('meps');
    my ($mep, @tabs) = @_;
    @tabs = @MEPSTABS unless @tabs;
    $dir->decho("MEP2ROWS %s", commed($mep, @tabs));
    my ($tab, $str, @vals, @rows, @records);
    foreach $tab (@tabs) {
	$str = "select * from $tab where mep = '$mep'";
	@records = $dir->{pgdb}{meps}->get_records($str);
	for (@records) {
	    (@vals) = @$_;
	    push @rows, [ $tab, @vals ];
	}
    }
    return @rows;
}

sub mep2val {
    my $dir = verdir(shift) or return;
    return if $dir->bell('nosql');
    return unless $dir->verdb('meps');
    my ($mep, $tab) = @_;
    $dir->decho("MEP2VAL $mep $tab");
    my $str = "select $tab from $tab where mep = '$mep'";
    my ($val) = $dir->{pgdb}{meps}->get_record($str);
    return $val;
}

sub mep2text {
    my $dir = verdir(shift) or return;
    my ($mep, @tabs) = @_;
    $dir->decho("MEP2TEXT %s", tabbed($mep, @tabs));
    @tabs = @MEPSTABS unless @tabs;
    return rows2text($dir->mep2rows($mep, @tabs));
}

sub mepsusage { return sprintf gettext("MEPS: Abfrage der EuroParlamentarier-Datenbank auf FFII.org\nErklaerungen finden sich unter\n\n\t%s\n"), "http://www.ffii.org/verein/knecht/meps/"; }

sub meps2rows {
    my ($usr, $dir) = verusr(shift) or return;
    my (@mep, $ntup, $i, $ind, $val, @vals, @kond, $mep, @meps, $pnom, @pnoms, $komit, @komits, $krol, $prol, $drol, $land, @lands, $euprt, @euprts, @rows, @records) = ();
    local $_;
    $dir->decho("MEPS2ROWS", commed(@_));
    return if $dir->bell('nosql');
    return unless $dir->verdb('meps');
    my @lines = $usr->ilines(@_);
    my $nmaxlim = zor($usr->perm('mepsnmax'), $usr->perm('rdbnmax'));
    my $nmax = $nmaxlim;
    my @report = @MEPSTABS;
    my @selecttabs = ( "pnom", "land", "euprt" );
    $dir->bell('help') && $dir->vecho(mepsusage);
    LINE : for (@lines) { 
	next if /^\#/ or /^\s*$/;
	$dir->decho("\tline %s", $_);
	($ind, @vals) = split /\s+/;
	IND : for ($ind) {
	    /(help|hilf)/ && do { $dir->vecho(mepsusage);next LINE; };
	    /^pick/ && do { $mep = $usr->pickmep(@kond);return $dir->mep2rows($mep, @report); };
	    do { $dir->vecho(gettext("Befehl %s ohne Argumente wirkungslos."), $_);next LINE; } unless @vals;
	    /^report$/ && do { @report = grep { defined } map { grep /^$_$/, @MEPSTABS && $_ } @vals;next LINE; };
	    /^(nmax|[dkp]rol)$/ && do { $val = numchk($vals[0]);return $dir->aua(53, "ungueltiger Zahlenwert %s", $vals[0]) unless defined $val; };
	    /^nmax$/ && do { $nmax = limchk($val, $nmaxlim);next LINE; };
	    /^[dkp]rol$/ && do { $val = limchk($val, 10); };
	    /^(deleg|drol)$/ && do { push @selecttabs, "deleg"; };
	    /^(komit|krol)$/ && do { push @selecttabs, "komit"; };
	    /^land$/ && do { push @selecttabs, "land"; };
	    /^[dkp]rol$/ && do { push @kond, "$ind >= $val";next LINE; };
	    /^(land|komit|euprt|deleg)$/ && do { push @kond, sprintf("upper(%s) in ( %s )", $_, sqcommed(map { uc } @vals));next LINE };
	    $dir->vecho(gettext("Konnte mit der Anweisung %s nichts anfangen."), $_);
	    $dir->vecho(&mepsusage);
	} }
    @records = $dir->{pgdb}{meps}->get_records(sprintf(qq{select mep from %s where %s}, join(" natural join ", nodups(@selecttabs)), vjoin(" and ", @kond)));
    @rows = ();
    $ntup = limchk(scalar @records, $nmax);
    $dir->decho("\tNTUP: %d, NMAX: %d, NMAXLIM: %d, PERM-MEPSNMAX: %d", $ntup, $nmax, $nmaxlim, $usr->perm('mepsnmax'));
    for ($i = 0; $i < $ntup; $i++) { ($mep) = @{$records[$i]};push @meps, $mep; };
    # for ($i = 0; $i < $ntup; $i++) { ($mep, $pnom, $land, $euprt) = @{$records[$1]};push @meps, $mep;push @pnoms, $pnom;push @lands, $land;push @euprts, $euprt; };
    for ($i = 0; $i < $ntup; $i++) {
	# push @rows, ["pnom", $meps[$i], $pnoms[$i]], ["land", $meps[$i], $lands[$i]], ["euprt", $meps[$i], $euprts[$i]];
	push @rows, $dir->mep2rows($meps[$i], @report);
    }
    $dir->decho("MEPS2ROWS finito");
    return @rows;
}

sub meps2text {
    my ($usr, $dir) = verusr(shift) or return;
    $dir->decho("MEPS2TEXT %s", commed(@_));
    return rows2text($usr->meps2rows(@_));
};

sub ffiimep2rows {
    my ($usr, $dir) = verusr(shift) or return;
    my $mep = shift; 
    $dir->decho("FFIIMEP2ROWS %s", $mep);
    return $dir->aua(214, gettext("kein Recht zum Lesen von Notizen ueber MdEP %s"), $mep) unless $usr->{perm}{meprem} or $usr->{perm}{"meprem:$mep"};
    return unless $dir->verdb;
    my ($uid, $replvl, $reprem, @rows, @records) = ();
    @records = $dir->{pgdb}{ffii}->get_records(sprintf(qq{select uid, replvl, reprem from repr where grp = 'mep' and vip = '%s' and (replvl > 0 or reprem is not null)}, $mep));
    for (@records) {
	($uid, $replvl, $reprem) = @$_;
	push @rows, [ $uid, $replvl, $reprem ]; 
    }; 
    return @rows;
};

sub ffiimep2text {
    my ($usr, $dir) = verusr(shift) or return;
    my ($mep) = @_; 
    $dir->decho("FFIIMEP2TEXT %s", $mep);
    return rows2text($usr->ffiimep2rows($mep));
}

sub uid2rows {
    my $dir = verdir(shift) or return;
    my ($uid, @tabs) = @_;
    $dir->decho("UID2ROWS uid %s tabs %s", $uid, commed(@tabs));
    return unless $dir->verdb;
    my ($tab, @rows, @row, @records) = ();
    foreach $tab (@tabs) {
	@records = $dir->{pgdb}{ffii}->get_records($tab, { uid=>$uid });
	for (@records) {
	    @row = @$_;
	    push @rows, [ $tab, @row ];
	};
    };
    return @rows;
}

sub uid2text {
    my $dir = verdir(shift) or return;
    my ($uid, @tabs) = @_;
    $dir->decho("UID2TEXT uid %s tabs %s", $uid, commed(@tabs));
    return rows2text($dir->uid2rows($uid, @tabs));
}

srand;
sub randfrak {
    my ($usr, $dir) = verusr(shift) or return;
    $dir->decho("RANDFRAK");
    my $rand = $usr->{rand};
    $dir->decho("\tvorbekannt: $rand");
    return $rand if $rand;
    $rand = rand;
    $usr->{rand} = $rand;
    $dir->decho("\tneu erzeugt: $rand");
    return $rand;
}

sub setkond {
    my ($land, $rand, $komit, $rol, @kond, @komits, @meps) = @_;
    $rand = rand;
    $komit = @komits[int($#komits * $rand * 1.5)]; 
    $rol = int(8 * ($rand**3));
    @kond = grep { $_ } sprintf($land && "upper(land) = '%s'", uc($land)), $komit && sprintf("upper(komit) = '%s'", uc($komit)), ($rol > 0) && sprintf("krol > %d", $rol);
    return $rand, $komit, $rol, @kond;
};

my @eumembroj = ('DE', 'FR', 'UK', 'IT', 'ES', 'PT', 'NL', 'BE', 'LU', 'DK', 'SE', 'FI', 'GR', 'AT');

sub pickmep {
    my ($usr, $dir) = verusr(shift) or return;
    my @kond = @_;
    my ($i, $land, $komit, $rol, $str, $rand, $ntup, $ntups, $mep, @meps, @komits, @records) = ();
    local $_;
    $dir->decho("PICKMEP kond: %s", commed(@kond));
    return if $dir->bell('nosql');
    return unless $dir->verdb('meps');
    $land = uc($usr->{data}{padr} && $usr->{data}{padr}{land}) || $eumembroj[0];
    # STRANGE Perl behavior: direct usr->{data}{padr}{land} query creates new record usr->{data}{padr} if not present yet
    $land = $eumembroj[0] unless grep /^$land$/, @eumembroj;
    @komits = split /[^\w]/, $usr->perm('pickmep', 'komits');
    @meps = map { my @row = @{$_};$row[2] } $usr->usel2rows('repr', 'mep');
    $dir->decho("already known meps: %s", commed(@meps));
    $rand = $usr->randfrak;
    ($rand, $komit, $rol, @kond) = setkond ($land, @komits) unless @kond; 
    $i=0;while ($i < 16) 
    { push @kond, sprintf("not mep in ( %s )", sqcommed(@meps)) if @meps;
      $str = sprintf("select mep from land natural join komit where %s", vjoin(" and ", @kond));
      @records = $dir->{pgdb}{meps}->get_records($str);
      return $dir->aua(147, gettext("Datenbank-Abfrage ohne Ergebnis")) unless @records;
      $ntups = scalar @records;
      $dir->decho("\tloop $i: $ntups tuples found with $str");
      if ($ntups > 0) { 
	  $ntup = int($ntups * $rand);
	  ($mep) = @{$records[$ntup]};
	  $dir->decho("NTUPS: %d, NTUP: %d, MEP: %s", $ntups, $ntup, $mep);
	  last if $mep; 
      };
  } continue { $i++;($rand, $komit, $rol, @kond) = setkond($land, @komits); };
    $dir->decho("\tPICKMEP result: $mep");
    return $mep;
}

##end package MEPS

##package FFIISTAT

sub sarjinamcu { 
    # return number of supporters
    my ($usr, $dir) = verusr(shift) or return;
    return if $dir->bell('nosql');
    return unless $dir->verdb;
    my @records = $dir->{pgdb}{ffii}->get_records('pnom', {}, 'uid');
    return scalar @records;
}

sub cmimanamcu {
    # return number of members
    my ($usr, $dir) = verusr(shift) or return;
    return if $dir->bell('nosql');
    return unless $dir->verdb;
    my @records = $dir->{pgdb}{ffii}->get_records('select uid from beitrag where bet > 12');
    return scalar @records;
}

sub firmamem {
    my ($usr, $dir) = verusr(shift) or return;
    return if $dir->bell('nosql');
    return unless $dir->verdb;
    my @records = $dir->{pgdb}{ffii}->get_records('select uid from firma where mem');
    return scalar @records;
}

sub sarjiurb {
    # return number of supporters in a city 
    my ($usr, $dir) = verusr(shift) or return;
    my ($urbnom, $urbid)= @_;
    return if $dir->bell('nosql');
    return unless $dir->verdb;
    my $str = sprintf("select uid from padr where upper(urb) like '%s' or upper(urb) = '%s'", uc($urbnom), uc($urbid));
    my @records = $dir->{pgdb}{ffii}->get_records($str);
    return scalar @records;
}

sub sarjiurbdist{
    # return list of e-mail addresses belonging to a city
    my ($usr, $dir) = verusr(shift) or return;
    my ($urbnom, $urbid) = @_;
    return if $dir->bell('nosql');
    return unless $dir->verdb;
    return unless $usr->perm('urbdist') or $usr->perm('urbdist', $urbid);
    my $str = sprintf("select pnom, mailuser, mailhost from pnom natural join mail natural join padr where upper(urb) like '%s' or upper(urb) = '%s')", uc($urbnom), uc($urbid));
    my ($pnom, $mailuser, $mailhost, @lines, @records) = ();
    @records = $dir->{pgdb}{ffii}->get_records($str);
    for (@records) { ($pnom, $mailuser, $mailhost) = @$_;push @lines, "$pnom <$mailuser\@$mailhost>"; };
    return lined @lines;
}

sub beitragsum {
    # return sum of member fees pledged by all members
    my ($usr, $dir) = verusr(shift) or return;
    return if $dir->bell('nosql');
    return unless $dir->verdb;
    my ($sum) = $dir->{pgdb}{ffii}->get_record('select sum(bet*12/mon) from beitrag where bet > 12 and bet < 1000');
    return $sum;
}

sub sarjiland () {
    # return number of supporters in a country
    my ($usr, $dir) = verusr(shift) or return;
    my ($land, $plz) = @_;
    my $str = spaced(sprintf("select uid from padr where upper(land) = '%s'", uc($land)), $plz && "and plz like '$plz%'");
    return if $dir->bell('nosql');
    return unless $dir->verdb;
    my @records = $dir->{pgdb}{ffii}->get_records($str);
    return scalar @records;
}    

sub sarjirepr {
    # return mail addresses of supporters who are contacting a particular representative
    my ($usr, $dir) = verusr(shift) or return;
    my ($grp, $vip) = @_;
    return unless $usr->perm('repr') or $usr->perm('repr', $grp) or $usr->perm('repr', $grp, $vip);
    return if $dir->bell('nosql');
    return unless $dir->verdb;
    my $str = sprintf("select uid, pnom, mailuser, mailhost, replvl, reprem from repr natural join pnom natural join mail where upper(grp) = '%s' and upper(vip) = '%s' order by replvl", uc($grp), uc($vip));
    my ($uid, $pnom, $mailuser, $mailhost, $replvl, $reprem, @lines, @records);
    @records = $dir->{pgdb}{ffii}->get_records($str);
    for (@records) {
	($uid, $pnom, $mailuser, $mailhost, $replvl, $reprem) = @$_;
	next unless $uid and $replvl;
	push @lines, "$uid\t$pnom \<$mailuser\@$mailhost\>\t$replvl\t$reprem";
    };
    return lined @lines;
}

sub ffiiprojresp {
    # am I the project leader?
    my ($usr, $dir) = verusr(shift) or return;
    my $proj = shift;
    my ($projuid) = $dir->{pgdb}{ffii}->get_record('proj', { proj=>$proj }, 'uid');
    return $dir->aua(137, gettext("project %s unknown"), $proj) unless $projuid;
    return 1 if $usr->{uid} =~ /^$projuid$/;
    my ($prmlvl) = $dir->{pgdb}{ffii}->get_record('projprm', { prmuid=>$usr->{uid} }, 'prmlvl');
    return $prmlvl >= 4 ? 1 : 0;
};

sub ffiiprojhlp {
    my ($usr, $dir) = verusr(shift) or return;
    my ($proj, $hlvl, @tabflds) = @_;
    $hlvl = 3 unless $hlvl;
    @tabflds = qw/uid hlplvl prmlvl asolvl hlprem prmrem asorem/ unless @tabflds; 
    $dir->decho("FFIIPROJHLP proj $proj hlvl $hlvl tabflds @tabflds"); 
    return if $dir->bell('nosql');
    return unless $dir->verdb;
    my (@records, @tab, @row, %hlplvl, %prmlvl, %asolvl, %hlprem, %prmrem, %asorem ) = ();
    @records = $dir->{pgdb}{ffii}->get_records("select distinct on ( uid ) projhlp.uid, hlplvl, prmlvl, asolvl, hlprem, prmrem from projhlp natural left outer join asoc join proj on ( proj.proj = projhlp.proj ) left outer join projprm on ( projprm.uid = proj.uid and projprm.prmuid = projhlp.uid ) where projhlp.proj = '$proj' and hlplvl >= $hlvl");
    for (@records) {
	my ($uid, $hl, $pl, $al, $hr, $pr, $ar) = @$_;
	$hlplvl{$uid} = $hl;
	$prmlvl{$uid} = $pl;
	$asolvl{$uid} = $al;
	$hlprem{$uid} = $hr;
	$prmrem{$uid} = $pr;
	$asorem{$uid} = $ar;
    };
    @tab = map {
	$uid = $_;
	@row = map {
	    my $res;
	    for ($_) {
		m(\A(uid|u)\Z)    && do { $res=$uid;last };
		m(\A(hlplvl|hl)\Z) && do { $res=$hlplvl{$uid};last };
		m(\A(prmlvl|pl)\Z) && do { $res=$prmlvl{$uid};last };
		m(\A(asolvl|al)\Z) && do { $res=$asolvl{$uid};last };
		m(\A(hlprem|hr)\Z) && do { $res=$hlprem{$uid};last };
		m(\A(prmrem|pr)\Z) && do { $res=$prmrem{$uid};last };
		m(\A(asorem|ar)\Z) && do { $res=$asorem{$uid};last };
	    }
	    $res;
	} @tabflds;
	[ @row ];
    } keys %hlplvl;
    return @tab;
}

sub ffiiprojdon {
    # donations to a project, queried by project leader
    my ($usr, $dir) = verusr(shift) or return;
    my $proj = shift;
    $dir->decho("FFIIPROJDON $proj"); 
    return if $dir->bell('nosql');
    return unless $dir->verdb;
    return unless $usr->ffiiprojresp($proj);
    my (@tab, @row, @records) = ();
    @records = $dir->{pgdb}{ffii}->get_records('projdon', { proj=>$proj }, qw(uid donsum donrem));
    for (@records) {
	(@row) = @$_;
	push @tab, [ @row ];
    };
};

sub ffiiprojtab {
    # table of projects by hierarchy and rank
    my $dir = verdir(shift) or return;
    my @tabflds = @_;@tabflds = qw/proj resp up url hlp don val valrem/ unless @tabflds; 
    return unless $dir->verdb;
    $dir->decho("FFIIPROJTAB tabflds: @tabflds");
    my ($resp, $proj, $up, $url, $fin, $rank, $val, $valrem, $sum, %projresp, %projup, %projurl, %projrank, %projval, %projvalrem, %projhlp, %projdon, %projfin, %projsortkey, @subprojs, @records);
    @records = $dir->{pgdb}{ffii}->get_records("select proj.uid, proj.proj, upproj, projurl, projfin, projrank, vallvl, valrem from proj natural join projrank left outer join projval on ( projval.proj = proj.proj and projval.uid = upuid(proj.proj) ) where projfin is null or current_date < projfin order by projrank");
    return $dir->aua(147, gettext("Keine Projekte gefunden")) unless @records;
    for (@records) {
	($resp, $proj, $up, $url, $fin, $rank, $val, $valrem) = @$_;
	$projresp{$proj} = $resp;
	$projup{$proj} = $up;
	$projurl{$proj} = $url if $url;
	$projfin{$proj} = $fin if $fin;
	$projrank{$proj} = $rank;
	$projval{$proj} = $val if $val;
	$projvalrem{$proj} = $valrem;
    }; 
    @records = $dir->{pgdb}{ffii}->get_records("select proj, sum(donsum) from projdon group by proj");
    for (@records) {
	($proj, $sum) = @$_;
	$projdon{$proj} = $sum;
    };
    @records = $dir->{pgdb}{ffii}->get_records("select proj, sum(hlplvl) from projhlp group by proj");
    for (@records) {
	($proj, $sum) = @$_;
	$projhlp{$proj} = $sum;
    };
    my @row;
    my @tab = map { 
	my $proj = $_;
	@row = map
	{ my $res;
	  for ($_) { 
	      /^proj$/ && do { $res=$proj;last };
	      /^resp$/ && do { $res=$projresp{$proj};last };
	      /^up$/ && do { $res=$projup{$proj};last };
	      /^url$/ && do { $res=$projurl{$proj};last };
	      /^hlp$/ && do { $res=$projhlp{$proj};last };
	      /^don$/ && do { $res=$projdon{$proj};last };
	      /^val$/ && do { $res=$projval{$proj};last };
	      /^valrem$/ && do { $res=$projvalrem{$proj};last };
	      /^fin$/ && do { $res=$projfin{$proj};last } };
	  $res; }
	@tabflds;
	[ @row ] }
    keys %projrank;
    return @tab;
};

sub ffiiuid2reks {
    # show table contents related to a user
    my ($usr, $dir) = verusr(shift) or return;
    my ($tab, $hom) = @_;
    $dir->decho("FFIIUID2REKS tab $tab hom $hom");
    return unless $dir->verdb;
    return $dir->aua(171, gettext("Funktion nur fuer Mitglieder zugaenglich")) unless $usr->{data}{asoc}{asolvl} > 1;
    return $dir->aua(170, gettext("Kein Zugang zu Tabelle %s")) unless $usr->{perm}{"hom:$tab"};
    my ($asolvl, $minlvl, $i, @tab, @row) = ();
    $minlvl = $usr->{perm}{"hom:$tab"};
    if ($minlvl > 1) {
	my ($asolvl) = $dir->{pgdb}{ffii}->get_record('asoc', { uid=>$hom }, 'asolvl');
	$asolvl = $asolvl || 0;
	return $dir->aua(169, gettext("Kein Zugang zu Eintraegen von %s in Tabelle %s", $hom, $tab)) if $asolvl < $minlvl;
    };
    my @records = $dir->{pgdb}{ffii}->get_records($tab, { uid=>$hom });
    for (@records) {
	@row = @$_;
	push @tab, [ @row ];
    };
    return @tab;
};

sub ffiiuid2mail {
    # return primary mail address of a user
    my $dir = verdir(shift) or return;
    my $uid = shift;
    $dir->decho("FFIIUID2MAIL $uid");
    return $dir->aua(197, gettext("Funktion %s braucht ein Argument"), "ffiiuid2mail") unless $uid;
    return unless $dir->verdb;
    my @records = $dir->{pgdb}{ffii}->get_records('mail', { uid=>$uid }, qw(mailref mailuser mailhost));
    return $dir->aua(193, gettext("Nutzer %s ist hier unbekannt"), $uid) unless @records;
    my ($i, $mailref, $mailuser, $mailhost, %mail, $mailadr);
    for (@records) {
	($mailref, $mailuser, $mailhost) = @$_;
	$mail{$mailref} = join("\@", $mailuser, $mailhost);
    };
    foreach $mailref ("norm", keys %mail) {
	last if $mailadr = $mail{$mailref};
    };
    $dir->decho("\tmailadr: $mailadr");
    return $mailadr;
};

sub blz2bank {
    # return bank name and place related to a bank code
    my $dir = verdir(shift);
    my $blz = shift;
    $dir->decho("BLZ2BANK $blz");
    return $dir->aua(197, gettext("Funktion %s braucht ein Argument"), "blz2bank") unless $blz;
    return unless $dir->verdb;
    my ($bank, $banklok) = $dir->{pgdb}{ffii}->get_record('blz', { blz=>$blz }, qw(blzbank banklok));
    return $dir->aua(193, gettext("Bank %s ist hier unbekannt"), $blz) unless $bank;
    return tabbed $bank, $banklok;
};

sub ffiiquery {
    my ($usr, $dir) = verusr(shift) or return;
    my $line = shift;
    local $_;
    return if $dir->bell('nosql');
    return unless $dir->verdb;
    my ($query) = $line =~ /^(\w.*\S)\s*/; 
    return $dir->aua(177, gettext("Unbrauchbare Anfrage %s", $query)) unless $query;
    $dir->vecho("FFII Query: $query");
    for ($query) {
	/\Aland\s+(\w{2})\s+([0-9]+)/ && return $usr->sarjiland($1, $2);
	/\Aland\s+(\w{2})/ && return $usr->sarjiland($1);
	/\Aurb\s+(\S+)\s+(\w+)/ && return $usr->sarjiurb($1, $2);
	/\Aurbdist\s+(\S+)\s+(\w+)/ && return $usr->sarjiurbdist($1, $2);
	/\A(beitrag|sum)/ && return $usr->beitragsum;
	/\A(sarji|support|unterst)/ && return $usr->sarjinamcu;
	/\A(cmima|mitgl|memb)/ && return $usr->cmimanamcu;
	/\Afirma/ && return $usr->firmamem;
	/\Arepr\s+(\w+)\s+(\w+)\Z/ && return $usr->sarjirepr($1, $2);
	/\Aperson\s+(\w+)\s+(\w+)\Z/ && return rows2text($usr->ffiiuid2reks($1, $2));
	/\Auid2mail\s+(\w+)\Z/ && return $dir->ffiiuid2mail($1);
	/\Ablz2bank\s+(\d+)\Z/ && return $dir->blz2bank($1);
	my ($cmd, @args) = split /\s+/, $query;
	for ($cmd) {
	    /\Aprojhlp\Z/ && return rows2text $usr->ffiiprojhlp(@args);
	    /\Aprojdon\Z/ && return rows2text $usr->ffiiprojdon(@args);
	    /\Amail2uids\Z/ && return spaced $usr->ffiimail2uids(@args);
	    /\Aprojtab\s*(.*)\Z/ && return rows2text $dir->ffiiprojtab(@args);
	};
    };
    return $dir->aua(83, gettext("Unverstaendliche Anfrage %s"), $query);
};

sub ffiistat {
    my ($usr, $dir) = verusr(shift) or return;
    return if $dir->bell('nosql');
    return unless $dir->verdb;
    return(join("\n\n", map { join(":\n\t", $_, join("\n\t", $usr->ffiiquery($_))) } @_) . "\n"); 
}

sub ffiimail2uids {
    # return user id_s related to a mail address
    my $dir = verdir(shift) or return;
    my ( $mailuser, $mailhost ) = @_;
    ( $mailuser, $mailhost ) = split(/\@/, $mailuser) unless $mailhost;
    $dir->decho("FFIIMAIL2UIDS mailuser = $mailuser, mailhost = $mailhost");
    return unless $dir->verdb;
    my ($uid, @uids, @records) = ();
    @records = $dir->{pgdb}{ffii}->get_records('mail', { mailuser=>$mailuser, mailhost=>$mailhost }, 'uid');
    for (@records) {
	( $uid ) = @$_;
	next unless $uid;
	push @uids, $uid;
    };
    return @uids;
}
sub ffiimail2uid { # deprecated, use ffiimail2uids instead
    # return user id related to a mail address
    my $dir = verdir(shift) or return;
    my @uids = $dir->ffiimail2uids(@_);
    return unless @uids;
    return $uids[0];
}

##end package FFIISTAT

##packages EPATEXT

sub pickpatlist {
    # return a list of patents to adopt
    my $dir = verdir(shift) or return;
    local $_;
    $dir->decho("PICKPATLIST");
    return unless $dir->verdb;
    return unless $dir->verdb('epat');
    my ($pat, $try, @rempats, @pats, @records) = ();
    @records = $dir->{pgdb}{ffii}->get_records('select pat from epat where length(rem) > 0');
    return unless @records;
    for (@records) { ($try) = @$_;push @rempats, $try; };	
    @records = $dir->{pgdb}{epat}->get_records('select pat from patattr where swprob > 950 or progclm > 3 order by swprob desc');
    return unless @records;
    for (@records) { ($try) = @$_;push @pats, $try unless grep /^$try$/, @rempats; };
    return @pats;
}

sub pickpatfile {
    my $dir = verdir(shift) or return;
    $dir->decho('PICKPATFILE');
    my $fo = dirslashed $dir->{frmbas}, 'epatlist.txt';
    my @pats = $dir->pickpatlist;
    return unless @pats;
    open FO, ">", $fo or return;
    for (@pats) { print FO $_, "\n" };
    close FO;
    $dir->decho("\twrote %d patents to file %s", $#pats, $fo);
    return $#pats, $fo;
}

sub epatlist {
    my $dir = verdir(shift) or return;
    $dir->decho("EPATLIST @_");
    return @{$dir->{epatlist}} if $dir->{epatlist};
    my $fi = dirslashed $dir->{frmbas}, "epatlist.txt";
    my ($pat, @pats) = ();
    if (open FI, "<", $fi) {
	$dir->decho("\treading lines ...");
	while ($pat = <FI>) { chop($pat);push @pats, $pat; };
	$dir->decho("\treading %d lines finito", $#pats);
    } else { return $dir->aua(43, "konnte Datei %s nicht lesen", $fi); };
    @{$dir->{epatlist}} = @pats;
    return @pats;
}

sub pickpat {
    my ($usr, $dir) = verusr(shift) or return;
    $dir->decho("PICKPAT");
    my @pats = $dir->epatlist;
    my $rand = $usr->randfrak;
    my $patnp = int($rand*$#pats);
    my $pat = $pats[$patnp];
    $dir->decho("\tpatent $pat at position $patnp picked.");
    return $pat;
};

##end package EPATEXT

##package KWIKI

sub dirgid {
    my ($dir) = @_;
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat($dir);
    return $gid;
};

my $KWIKIDIR = "/var/www/cgi-bin/kwikimj04/database";

sub kwikiperm {
    # am I allowed to overwrite a kwiki source page by submission via knecht?
    my ($usr, $dir) = verusr(shift) or return;
    my ($wikipag) = @_;
    my $perm = $usr->{perm}{"kwiki:$wikipag"} || $usr->{perm}{kwiki};
    return $perm if $perm;
    my ($uid) = $dir->{pgdb}{ffii}->get_record("select uid from wikipags where wikipag = '$wikipag'");
    return unless $uid;
    return $dir->aua(214, gettext("Keine Erlaubnis zum Schreiben der Wikiseite %s"), $wikipag) unless $uid =~ /^$usr->{uid}$/; 
    return 1; 
}


sub kwiki {
    my ($usr, $dir) = verusr(shift) or return;
    my ($tainted, $kmd) = @_;
    $dir->decho("KWIKI: execute command '$kmd' on page '$wikipag'");
    my ($wikipag) = $tainted =~ m(\A([A-Z]\w+[a-z]+\d*[A-Z][a-z])\Z);
    return $dir->aua(176, gettext("ungueltige Wikiseite %s"), $tainted) unless $wikipag;
    my $file = "$KWIKIDIR/$wikipag";
    my $text = "";
    local $_;
    if (-r $file) {
	open FI, "<$file";
	$text = join "", <FI>;
	close FI;
    };
    return $text unless $kmd =~ /^put$/;
    return unless $usr->kwikiperm($wikipag);
    $dir->UMask('ExekUmask');
    return $dir->aua(175, gettext("darf Verzeichnis %s nicht zum Schreiben oeffnen"), $KWIKIDIR) unless -W $KWIKIDIR;
    return $dir->aua(174, gettext("darf Datei %s nicht zum Schreiben oeffnen"), $file) if -r $file and not -w $file;
    return $dir->aua(173, gettext("kann Datei %s nicht zum Schreiben oeffnen"), $file) unless open(FO, ">", $file);
    print FO join("", <STDIN>);
    close FO;
    chown -1, dirgid($KWIKIDIR), $file;
    $dir->UMask('umask');
    $dir->vecho(gettext("Datei %s geschrieben.\nHier noch einmal die ueberschriebene fruehere Version:"), $file);
    return $text;
}

##end package KWIKI

##package DISPATCH

sub zubefehl {
    my ($usr, $dir) = verusr(shift) or return;
    my ($kmd, @args) = @_;
    return $dir->aua(73, gettext("Befehls-Argument fehlt")) unless $kmd;
    if ($kmd =~ m((epat|wort|dabei|meps|ffii|proj|kwiki|help|hilfe))) { $kmd = $1; } else { return $dir->aua(76, gettext("WIE BITTE?\nUnbekannter Befehl\n\t%s"), $kmd); }
    $dir->vecho(gettext("JAWOHL Nutzer %s!\nZU BEFEHL: %s %s\n"), $usr->{uid}, $kmd, spaced @args);
    $usr->logprint('verb', commed($kmd, @args));
    my ($res);
    local $_;
    for ($kmd) {
	/\Adabei\Z/ && do { $res = $usr->dabei(@args);last };
	/\Ameps\Z/ && do { $res = $usr->meps2text(@args);last };
	/\Aepat\Z/ && do { $res = $usr->epatext(@args);last };
	/\Akwiki\Z/ && do { $res = $usr->kwiki(@args);last };
	/\Affii\Z/ && do { $res = $usr->ffiistat($usr->ilines(@args));last };
	$dir->vecho(knechtusage);
    };
    return $res;
}

sub reinundran {
    my ($dirstr, $bells, $kmd, $subkmd, $file, @args) = @_;
    my $dir = newdir($dirstr, $bells);
    verdir $dir or return;
    my $usr = newuser($dir, $file);
    verusr $usr or return;
    my $res = $usr->zubefehl($kmd, $subkmd, @args);
    return $res;
}

##end package DISPATCH 
##end package Knecht
 
return 1;


# Local Variables:
# coding: utf-8
# srcfile:/i2p/aktiv/perl/Knecht.pm
# mode: perl
# End:
