package A2E::Dokfs;
use utf8;

=head1 NAME

A2E::Dokfs

=head1 VERSION

This describes version B<0.1.6>

=cut

our $VERSION = '0.1.6';

=head1 DESCRIPTION

a2e multilingual hypertext file system library, used by many small programs,
based on A2E::Daba and A2E::Lokvars, basis for A2E::Mktdir::* et al.

This "file system" is an abstraction layer on top of normal file systems.  It
should allow you to perform operations such as change, move, copy, delete etc
on whole document nodes which comprise a rich set of metadata, rather just on
files and directories.

It is a successor of the A2E::Dokfs library and thus already quite mature at
version 0.0.1.

=head1 BUGS, LIMITATIONS

Search for 'BUGS' statements in some functions.

=head1 TODO

=over

=item allow setting of srcfpfx in each directory

Functions like dok_pre_lng_faylz and rmdok should use whatever prefix is found to be in use in the concerned directory.

The same heuristics should be used to determine MPX in a2e/defs.mk and the like.

=item Modularise

using the get_dok_plugins approach, retain only core functionality, move major parts out into mix-in libraries, built along the model of A2E::Lokvars. Turn the Mktdir libraries into mix-in libraries of this type.

=item Internalise 

DONE with Daiku: Use Tinymake or the like to incorporate the makefile rules that are part of document creation.  Turn calls of standalone programs into function calls.

Consider combination with Psh to create a Dokfs shell.

=item Real Alias Mechanism

The document alias should be registered in a separate table with proper constraints, not in doktexts.

=item hsprintf_repl configuration

Make the hsprintf_repl default settings user-configurable at the A2E::Dokfs level.
See explanation o hsprintf and msg in A2E::Prog.

=back

=head1 Changelog

=over
=item v 0.1.5 2009-01-01

allow template-based document creation and handling, e.g.

    mktdir0 -T oas_ont -V mm=04 -V aa=09 ont oas_ont0904 de zh

where variable document metadata are prestored in the template files /opt/a2e/share/tmpl/oas_ont_* and
variable parts are transmitted via the -V expressions.

=back



=head1 PREREQUISITES

    A2E::Daba(3)
    A2E::Lokvars(3)
    ...

=cut

use strict;
use base 'A2E::Tmplvars', 'A2E::Daba', 'A2E::SVN', 'A2E::Lokvars', 'A2E::Tmplkonf';
use strict;use warnings 'all';no warnings 'uninitialized';
# use diagnostics;
# use Data::Dumper;
use File::Spec::Functions qw(splitdir splitpath catdir catfile);
use File::Basename;
use File::Touch;
use Cwd;
our $novitas = $ENV{NOVITAS};

our %MSGS = (
    # diroldoks => 'directory %d squatted by documents %o, %l and perhaps more',
    noatrtups => 'No attributes given for a column identified by keys %K with values %V, giving up on table %t',
    idenoval => 'identificatory column %i aka variable %l has no value, giving up on table %t',
    doknoabsurl => 'no absurl found for dok %D',
    notopdok => 'found no topdok for document %d',
    notopnopre => 'dok %d is not in topdoks and yet has no predoks',
    nildirinfo => 'attempting to read directory document info from nil directory',
    raidirinfo => 'attempting to read directory document info from root directory %d',
    nondirinfo => 'attempting to read directory document info from nondirectory %d',
    nordirinfo => 'attempting to read directory document info from unreadable directory %d',
    grokurl => 'cant grok url %u',
    doknodir => 'document %d has no directory',
    dokssquatdir => 'directory %d squatted by multiple documents %D',
    dirnodok => 'unable to infer dok from names of files found in dir %d',
    funkbadv => 'at %(PL) bad value %v given for %k',
    notopnoprop => 'failed to read any properties of node %n from tree %a even though we have not yet reached the top',
    infinilup => 'risk of infinite loop, refusing to add element %e to list %L',
    fdoknodir => 'no directory found for document %d listed in file %f',
    doknedir => 'directory %d of document %k does not exist',
    nolangurl => 'kann URL von %d nicht in Landessprache liefern',
    dirnodir => 'no directory found at %d',
    nodir => 'Verzeichnis %d nicht vorhanden',
    nordir => 'Verzeichnis %d nicht lesbar',
    nowdir => 'Verzeichnis %d nicht schreibbar',
    dirnolangs => 'no langs specified in directory %d, looking at file names',
    DirNoLangs => 'can by no means find any languages in directory %d',
    dirnodokprop => 'couldnt find dokprop dir for dok %d',
    nofyl => 'missing file %f',
    nofylr => 'no file to read from %f',
    dirnodokfyls => 'no dokfyls found for document %D in dir %d',
    dokdirnosubs => 'no menu_subdoks available for dir %d of node %n',
    doknodoksf => 'doksfile failure on %D: %m',
    mapnil => 'lookup map %n is empty',
    hacekz => '%n hash is already there and has values %v',
    lstekz => 'found listref %L',
    doknofol => 'no leaf name for dok %d; go there and make dokdata' );

=head3 $arg = $m->valid_\w+($lihs,$arg,$vahr): validators
for use with vlpuc, opuc, vopuc
=cut

sub valid_dok { 
    my ($m,$lihs,$dok,$vahr) = @_;
  NODOK: {
      last if $dok;
      return '' if $vahr->{__flagp__}->{let};
      $dok = $m->get_dok($lihs) if $vahr->{__flagp__}->{get};
    }
    $dok = $m->alidok($dok);
  CHK: {
      last if $m->{dokprop}->{$dok};
      my $url = $m->dok2absurl($dok);
    NOURL: {
	last if $url;
	return '' if $vahr->{__flagp__}->{let};
	$m->ustop('bad document %D', D => $dok) if !$url;
      };
      my $dir = $m->url2dir($url);
    NODIR: {
	last if -d $dir;
	$m->uwarn('bad dir %D for document %d', d => $dok, D => $dir);
	last CHK;
      };
      $m->{dokprop}->{$dok}->{dir} = $dir;
    };
    $dok };
sub valid_tmpl { 
    my ($m,$lihs,$tmpl,$vahr) = @_;
  NOTMPL: {
      last if $tmpl;
      return '' if $vahr->{__flagp__}->{let};
      $tmpl = $m->get_tmpl($lihs) if $vahr->{__flagp__}->{get};
    };
    $m->ustop('bad tmpl %T', T => $tmpl) if !-d $m->tmpldir($tmpl);
    $tmpl;
};
sub valid_dir {
    my ($m,$lihs,$dir,$vahr) = @_;
  NODIR: {
      last if $dir;
      return '' if $vahr->{__flagp__}->{let};
      $dir = $m->get_dir($lihs,$vahr->{dok}) if $vahr->{__flagp__}->{get};
    };
    $m->pstop('invalid directory %D', D => $dir) if !-d $dir;
    $dir;
}
sub valid_pwd {
    my ($m,$lihs,$pwd,$vahr) = @_;
  NOPWD: {
      last if $pwd;
      return '' if $vahr->{__flagp__}->{let};
      $pwd = $m->set_pwd($lihs) if $vahr->{__flagp__}->{get};
    };
    $m->pstop('inode of . not same as of pwd %D', D => $pwd) if $m->inod($pwd) ne $m->inod('.');
    $pwd;
};
sub valid_lang {
    my ($m,$lihs,$lang,$vahr) = @_;
  NOLANG: {
      last if $lang;
      return '' if $vahr->{__flagp__}->{let};
      $lang = $m->valid_get_lang($lihs,$lang,$vahr) if $vahr->{__flagp__}->{get};
    };
    $m->pstop('invalid language %L', L => $lang) if $lang !~ m(\A\w{2}\Z);
    $lang;
};
sub valid_get_lang { 
    my ($m,$lihs,$lang,$vahr) = @_;
    my $langp = $vahr->{langp} || {};
    $lang ||= $lihs->getstr('__lang__') || $lihs->getstr('__lang') || $lihs->getstr('lang') || $m->pvar('lang');
    return $lang if $lang;
    my @langs = ();
  LANGP: {
      last if !%$langp;
      @langs= $m->ref2list($vahr->{langs});
    LANGS: {
	last if @langs;
	@langs = $lihs->getlst('langs');
	last if @langs;
	@langs = $m->plst(langs => 1);
	last if @langs;
	$m->pstop('no langs found');
      };
      $langp->{$_} = 1 for @langs;
      $vahr->{langp} = $langp;
      $vahr->{langs} = \@langs;
    };
    $lang = $langs[0] if !$langp->{$lang};
    $lang;
};
sub valid_littups { 
    my ($m,$lihs,$littups,$vahr) = @_;
    $m->pstop('littups must be present') if !$littups;
    return {} if !$littups and $vahr->{__flagp__}->{let};
    my $ref = ref $littups;
    $m->pstop('littups %L is not a reference', L => $littups) if !$ref;
    $m->pstop('littups %L is not a hashref but an %r', L => $littups, r => $ref) if 'HASH' ne $ref;
    $littups;
}
sub valid_mlid {
    my ($m,$lihs,$lit,$vahr) = @_;
    my $mlid = $m->lit2mlid($lit);
    $m->pstop('can not mlid_put_mltxt without mlid') if !$mlid;
    $mlid;
}
sub valid_rel2map {
    my ($m,$lihs,$relspe) = @_;
    $m->pstop(funnovar => v => 'relspe') if !$relspe;
    my $rekmap = $m->relspe2rekmap($relspe);
    $m->pstop('could not obtain a rekmap from relspe %r', r => $relspe) if !$rekmap;
    $m->pstop('rekmap %r does not point to an array', r => $rekmap) if 'ARRAY' ne ref $rekmap;
    $rekmap;
};

=head3 $ok = $m->dokfs_defvars($lihs): initiate

=cut
sub dokfs_defvars {
    my ($m,$prog,$lihs) = shift->qpuc('dokfs_defvars',@_) or return;$lihs = $m->get_lihs($lihs);
    $m->prog_msgdefs('dokfs', %MSGS);
=head1 VERSION

This describes version B<0.1.6> of A2E::Dokfs.

=cut

    $m->defpvar(progver => '0.1.6');
    $m->{dokurl} = {};
    $m->{doklab} = {};
    $m->{alidok} = {};
    $m->{get_dok_plugins} = {};
    $m->{dokpre} = {};
    $m->{comment_regex} = {};

=head1 OPTIONS

=over

=item --dok oas_ont0812

=cut

    $m->lihs_define($lihs,'dok','$');

=item --langs en --langs de --langs fr

=cut
    $m->konfig_define(['langs','L'],'@');
=item --subdoks
=cut
    $m->{konfig}->define('subdoks=s@');
=item --grpdoks
=cut
    $m->{konfig}->define('grpdoks=s@');
=item --predoks
=cut
    $m->{konfig}->define('predoks=s@');
=item --postdoks
=cut
    $m->{konfig}->define('postdoks=s@');

=item --htmlesc
=cut
    $m->{konfig}->define('htmlesc!');
=item --lifmt '%s'
=cut
    $m->konfig_define('lifmt', 's', '%');
=item --unifnom '%ptop-%d.%l.txt'
=cut
    $m->konfig_define('fnom2ffol', '%');
    $m->konfig_define('tmpl_fnoms', 's', 'dok,nav,mak,rak,dak,dfs');
    $m->konfig_define('unifnom', 's', '%ptop-%d.%l.txt');
=item --tml_outfayl html index.%l.html    
=cut
    $m->konfig_define('tml2outfayl','%', { multemp => '_top-%d.%l.txt', html => 'index.%l.html', latex => '%d.%l.tex', mldbweb => '%d.%l.xml' });
    $m->konfig_define('tml2outmode','%', { multemp => 'fundamental', html => 'html', latex => 'latex', mldbweb => 'xml' });
=item --mulfnom '%pdok.%d.txt'
=cut
    $m->konfig_define('mulfnom', '$', '%pdok.%d.txt');
=item --prvfnom '%pprv.%d.txt'
Private parameters of one directory, not transmitted to children
E.g. used for hta_prv = 1 which causes a .htaccess file to be written here but not separately for each subdirectory.
=cut
    $m->konfig_define('prvfnom','$', '%pprv.%d.txt');
=item --navfnom '%nav.%d.txt'
=cut
    $m->konfig_define('navfnom','$','%pnav.%d.%l.txt');
=item --lexfnom '%plng.%d.%l.txt'
=cut
    $m->konfig_define('lexfnom','$', '%plng.%d.%l.txt');
    $m->konfig_define('posttmplfnom0','$', 'lng_tmpl.txt');
    $m->konfig_define('posttmplfnom', '$', 'lng_tmpl.%l.txt');
    $m->konfig_define('antetmplfnom0', '$', 'pre_tmpl.txt');
    $m->konfig_define('antetmplfnom', '$', 'pre_tmpl.%l.txt');
=item --lexfnom0 '%plng.%d.txt'
=cut
    $m->konfig_define('lexfnom0', 's', '%plng.%d.txt');
    $m->konfig_define('langsfnom','s','%plangs');

=item --lng_faylz_mul_uni

Multilingual vocabulary lng.perllibdoku.txt should come before monolingual vocabulary lng.perllibdoku.de.txt

Traditionally it was the other way around.
Starting from version 0.4.5 this is set to 1 in the local configuration file dokfs

=cut
    $m->konfig_define('lng_faylz_mul_uni', '!', 0);
=item --antefnom0 '%ppre.%d.txt'

File with lexical definitions that come before anything else.  Suitable especially for numeric parameters on which decisions in templates and template vocabulary files are then based.

=cut
    $m->konfig_define('antefnom0', 's', '%ppre.%d.txt');
=item --antefnom '%ppre.%d.%l.txt'

File with lexical definitions that come before anything else.  Suitable especially for numeric parameters on which decisions in templates and template vocabulary files are then based.

=cut
    $m->konfig_define('antefnom', 's', '%ppre.%d.%l.txt');

=item --post_lexdef_fmt 'unexport %s := %s'

default format of lexical definitions in the language neutral vocabulary file read at the end, using printf syntax with two arguments: variable name and variable value.
=cut
    $m->konfig_define('post_lexdef_fmt', 's', '%s := %s');

=item --ante_lexdef_fmt '%s ?= %s'

OBSOLETE
default format of lexical definitions in a pre-definition vocabulary file, using printf syntax with two arguments: variable name and variable value.

=cut

    $m->konfig_define('ante_lexdef_fmt', 's', '%s ?= %s');
    
=item --doktmplfnom 'dok_tmpl.txt'

=cut
    $m->konfig_define('doktmplfnom','s', 'dok_tmpl.txt');

=item --navtmplfnom 'nav_%t_tmpl.txt'
=cut
    $m->konfig_define('navtmplfnom','s', 'nav_tmpl.txt');

=item --tmplngantefnom0 'lang_pre.txt'

file naming template for template-related non-language-specific pre-vocabulary file

=cut
    $m->konfig_define('tmplngantefnom0','s', 'lang_pre.txt');

=item --tmplngantefnom 'lang_pre.%l.txt'

file naming template for template-related non-language-specific pre-vocabulary file

=cut
    $m->konfig_define('tmplngantefnom','s', 'lang_pre.%l.txt');
=item --tmplnglangfnom 'lang.%l.txt'

file naming template for template-related language-specific vocabulary file

=cut
    $m->konfig_define('tmplnglangfnom','s', 'lang.%l.txt');
=item --tmplngpostfnom 'lang.txt'

file naming template for template-related non-language-specific post-vocabulary file.
Placeholder 1 is the language.

=cut
    $m->konfig_define('tmplngpostfnom','s', 'lang.txt');
=item --konf_tmpl_fnom %t_konf_tmpl.txt

filename format for configuration files templates, arg1 to be filled by $m->pvar('tmpl').
This is appended to $m->pvar('topdir')/$m->pvar('topdok')_ or, when installing the latter,
$m->pvar('tmpldir')
    
=cut
    $m->konfig_define('konf_tmpl_fnom','s', '%t_konf_tmpl.txt');
=item --svnbas2dir
=cut
    $m->cache_define('svnbas2dir','%');
=item --primdom a2e.de
=cut
    $m->cache_define('primdom','s');
=item --primdir /srv/www/a2e
=cut
    $m->cache_define('primdir','s');
=item --primurl http://a2e.de
=cut
    $m->cache_define('primurl','s');
=item --svnbas_regexps

regexps for matching 'sig_oas1312' into ('oas', '13', '12') whence '/sig/oas/13/12'

=cut
    $m->cache_define('svnbas_regexps','@'); 
=item --html_suffix html
=cut
    $m->cache_define('html_suffix','s', 'html');
=item --urldirs

Using the dirurls variable and its inversion dirurls, we try to have
as simple as possible mappings between the web path and the file
system path on the one hand and the SVN path and file system path on
the other:

    a2e.de/sig/i2p/07/10 -->  /sig/i2p/07/10    <-- /svn/sig_i2p0710/
    a2e.de/index.html    -->  /a2e/index.html   <-- /svn/a2e/index.html
    eupat.ffii.org/07/10 -->  /eupat/07/10      <-- /svn/eupat0710

=cut
    $m->konfig_define('urldirs','%');
=item --dirurls

inversion, derived from urldirs but can also be set manually.

=cut
    $m->konfig_define('dirurls','%');
=item --lokdoms

=cut
    $m->konfig_define('vihdoms', '%');
=item --domvihs

inversion, derived from vihdoms but can also be set manually

=cut
    $m->konfig_define('domvihs', '%');
=item --dirurls

inversion, is derived from urldirs but can also be set manually.

=item --get_dok_plugins

several ways of recognising a document, insertable and removable.

=cut
    $m->konfig_define('get_dok_plugins','@', [qw(pvar dir konfig)]);
=item --comment_format
=cut
    $m->konfig_define('comment_format', '%');
=item --varsfnom @var.%s.mk
=cut
    $m->konfig_define('varsfnom', 's', '%svar.%s.mk');
=item --pakfnoms PAK.mk
names of files in which paramaters related to the package or to the directory are stored that should be shared by the document processor
=cut
    $m->konfig_define('pakfnoms', 's@');

=item style_tags
=cut
    $m->konfig_define('style_tags', '%', { star => '[* *]', html => '<!-- -->', template => '['.'% %'.']', asp  => '<% %>', php => '<? ?>', mason => '<% %>', metatext => '%% %%' });

=item --dokdatum

Date of the current document, in '2008-08-08' style notation.
This should be the an unequivocal and largely immutable attribute, such as date of creation, the deadline of delivery.
The value of the 'dokdatum' configuration variable can be overridden by the value of a template variable named 'dokdatum' or by the value of a template variable named by the value of a template variable named 'dokdatum_var'.

=cut

    $m->{konfig}->define('dokdatum=s');

=item --verdatum

Date of latest version of (i.e. latest changes to) the current document.

=cut

    $m->{konfig}->define('verdatum=s');

=item --getkanals

news/rss channel from which the current document publishes news, scalar but with possibility of indicating several, separated by commas or spaces

=cut

    $m->{konfig}->define('getkanals|kanals=s');

=item --putkanals oas_adv,adv:-1

news/rss channels into which the current document is inserted as a news item, scalar but with possibility of indicating several, separated by commas or spaces, and a possibility of attaching, after a colon, a degree of importance to each, with 0 representing normalcy and positive or negative integers representing increased or decreased degrees of importance respectively. 

=cut

    $m->{konfig}->define('putkanals=s');

=item --news_start 2008-08-01

print only news items whose date is not earlier than the date given here.
print even the earliest items if no date is specified.

=cut

    $m->{konfig}->define('news_start=s');

=item --news_stop 2008-09-01

print only news items whose date is smaller (at least 1 day earlier) than the date given here.
print everything up to now if not specified.

=cut

    $m->{konfig}->define('news_stop=s');

=item --news_limit

Print maximally this number of documents per channel.

No limit if set to zero, which is the default.

=cut

    $m->{konfig}->define('news_limit=i', { DEFAULT => 0 });

=item --news_level 3

Print only news items with priority level as indicated or higher.

When comparing, subtract 1 if the date is not of the current month, 2 if not of the current year.

Premium news have a rank of 3 when they are emitted.   Setting news_level to 3 would mean that only
premium news of the current month are allowed in this channel.

To set the level of importance of a particular news item use the --putkanals option.

=cut

    $m->{konfig}->define('news_level=i', { DEFAULT => 0 });

=item --grpdir .

OBSOLETE, now dynamic textchunk sems2subflat.
Node group directory.
Let the document be subordinate not to the node in its normal parent directory but to the node of the parallel directory indicated by the argument.
The node group directory can be the current directory '.', in which case the document is created in a parallel directory under the parent directory.
If the grpdir argument is empty, the document will be subordinate to the current document in the normal way, i.e. as a subdirectory. 

=cut

    $m->cache_define('grpdir', 's');

=item --news_*s

=over

=item news_doks

To which document the headline of a particular channel should link

=cut

    $m->konfig_define('news_doks','%');

=item --news_titles

Which template variable should be used for the title of a particular channel

=cut

    $m->konfig_define('news_titles','%');

=item --news_title_varnom0 news_tit

=cut

    $m->konfig_define('news_title_varnom0', '$', 'news_tit');

=item --news_title_varfnom %s_news_tit

=cut

    $m->konfig_define('news_title_varfnom','$', '%s_news_tit');

=item --news_descrs

Which template variable should be used for the description of a particular channel

=cut

    $m->konfig_define('news_descrs','%');

=item --news_descr_varfnom '%s_news_des'

=cut

    $m->konfig_define('news_descr_varfnom','$', '%s_news_des');

=item --news_limits oas_adv 5

Limit of number of news items in a particular channel

=cut

    $m->konfig_define('news_limits','%');

=item --news_levels oas_pub 1 --news_levels oas_adv -1 

Threshold of news for a particular channel

=cut

    $m->konfig_define('news_levels','%');

=item --news_starts oas_adv 2009-03-01 --news_starts oas_pub 2009-01-01

date at which the news of a particular channel should begin

=cut

    $m->konfig_define('news_starts','%');

=item --news_stops oas_adv 2009-03-31 --news_stops oas_pub 2009-12-31

dte before which the news of a particular channel should end

=cut

    $m->konfig_define('news_stops','%');

=item --rss_fnom C<%s.news.%s.rss>

I<format of name of rss file with args dok and lang>

=cut

    $m->konfig_define('rss_fnom','$', '%s.news.%s.rss');

=item --news_kanal oas_akt

Establish the named document as a news channel.
If the name is '1' or '*', use the current document identifier.
If the name is '0' or empty, do not establish a news channel.

=cut

    $m->konfig_define('news_kanal');

=item --news_kanalrem 'jeder Auftrag eine Nachricht'

=cut

    $m->konfig_define('news_kanalrem');

=item --news_supkanal oas

superordinate channel -- ancestor of which the current channel becomes a subordinate

=cut

    $m->konfig_define('news_supkanal');

=item --news_kanaldat 2009-03-14

date of establishment of channel

=cut

    $m->konfig_define('news_kanaldat');

=back

=item --doktabs

database tables in which a document (dok) is referenced

=cut

    $m->konfig_define('doktabs','@');

=item --doktabs_dok

name of field within each table that references dok, if it is not called 'dok'.

=cut
    $m->konfig_define('doktabs_dok','%');
    $m->konfig_define('doktabs_maxrows','%');
=item --subopts grpdir=. --subopts dokdatum=2009-04-30

Any subdocument will have the given scalar configuration variable set.
Do not set --subopts tmpl, use subtmpl instead.

=cut

    $m->konfig_define(['subopts','S'],'%');

=item --dokdata_cache

Cache in memory any document data of any documents referenced in the text via dok2data.
The speed gain will be worth the memory increase only when the documents are referenced repeatedly. 
On by default but it might be sensible to turn it off in the local configuration file of certain nodes.

=cut
    $m->cache_define('dokdata_cache', '!', 1);

=item --supdok_progvars supdok_progvars mktdir_user=1 --supdok_progvars mktdir_time=1

text chunks that are not used as template variables when they come from an external document's vocabulary database (e.g. the parent of the actual document that we are creating with A2E::MKtdir).

Probably OBSOLETE.

=cut
    $m->konfig_define('supdok_progvars','%');

    $m->konfig_define('dok_regexp', 's', '\A[a-z][a-z,0-9,A-Z,_]+\Z');

=item --svn_root '\/\S*\bsvn'

regex matching the part of each pathname under which the subversion repository trees on the local harddisk begin.
it is assumed to be surrounded by \A and \b, i.e. begin at the beginning of the pathname and end at a word border.
This is consulted only in the rare cases where info cannot be directly collected from the local svn repository via the svn_info function, e.g. in cases where an application is run by Apache under identity of a user that has no svn access.

=cut

    $m->konfig_define('svn_root', 's', '\/\S*\bsvn');

=item sitemap-related options
=cut

    $m->konfig_define('sitemap_priority', 'f', 0);
    $m->konfig_define('sitemap_moddist', 'i', 0);

=item htaccess-related options 

Deprecated, use textchunks of same names in @pre.$dok.txt or, even better, lang_pre.txt of document type instead.

=cut
    $m->lihs_define($lihs,'privat', '!', 0);
#    $m->cache_define('hta_sig', 's', 'oas');
#    $m->cache_define('hta_org', 's', 'a2e');

=item --inddok a2e

top-level document of current web host where sitemap index is to be found.
used by mktdir when creating a new top node, by sitemap_tmplfil when compiling a sitemap, and by the top node sitemap index form.

=cut

    $m->cache_define('inddok', 's');

=item --nlangkols 1

Maximal number of language columns juxtaposed to each other in the generated document.
Default is 1, meaning that all resulting documents are monolingual.

E.g. if C<nlangkols> is 2 and the documents languages are de en zh ja, then we get one monolingual original and 3 bilingual versions:

	de
	de en
	de zh
	de ja

If C<nlangkols> is 3, we get

	de
	de en
	de en zh
	de en ja

1 monolingual, 1 two-column bilingual and 2 three-column trilingual versions.

This will work together with the litscat template macro of A2E::Template::Context, which in turn
will invoke special macros like

	* 

	

so as to typeset text parts of each level in the specifically appropriate way, resulting in something like

	* Chemische Verbindungen --- Chemical Compounds

	| Karbide | Carbides | 碳化物 |
	| Karbonate | Carbonates | 碳酸化合物 |

To make this work we create a hash pointer $m->{lang_tmplvars} which contains the language variables of several languages and make $m->{tmplvars} point to $m->{lang_tmplvars}->[$lang] where $lang refers to the current language.   This has been tentatively done in &A2E::MLHT::mlht_set_langvars.

=cut

    $m->cache_define('nlangkols', 'i', 1);

=head2 Debugging Options

=head3 --tmpltoks_ok

Whether the tmpltoks extension that will allow multilingual metadata to be written into a special table like 'flddes' is enabled yet.
Set this on for debugging only at the moment.

=cut
    $m->cache_define('tmpltoks_ok', '!');

=head3  --idelits_ok

Whether the poorly understood idelits accumulation functionality is to be used.

It is used only in A2E::Dok2data, see explanations C<listref idelits>.

=cut

    $m->cache_define('idelits_ok', '!', 1);
    $m->cache_define('lit2mlid', '%');

=item --smprior_min 0.5

Minimal smprior (search machine priority, two digit rational between 0 and 1) needed for a news item to be listed.

=cut

    $m->lihs_define($lihs,'smprior_min', '$', '0.5');

=head1 FILES

configuration: _dokfs, ~/dokfs.konf, /etc/opt/a2e/dokfs.konf
=cut
    $m->{var2validp}->{dok} = \&valid_dok;
    $m->{var2validp}->{dir} = \&valid_dir;
    $m->{var2validp}->{pwd} = \&valid_pwd;
    $m->{var2validp}->{tmpl} = \&valid_tmpl;
    $m->{var2validp}->{lang} = \&valid_lang;
    $m->{var2validp}->{littups} = \&valid_littups;
    $m->{var2validp}->{mlid} = \&valid_mlid;
    $m->{var2validp}->{lit} = \&valid_lit;
    $m->{var2validp}->{rel2map} = \&valid_rel2map;
    $m->konfayl('dokfs.konf');
    $m->{progvars2hsprintf} = { tmplang => 'f', lang => 'l', dok => 'd', tmpl => 't', srcfpfx => 'p', langs => 'L', tmls => 'F', sems => 'S' }; # file:/phm/19/05/30/sig/_lng.phm_pub_sig190530.txt::pvars2hsprf
    $m->{hsprintf2progvars} = {};
    while (my ($k,$v) = each %{$m->{progvars2hsprintf}}) { $m->{hsprintf2progvars}->{$v} = $k };
    $m->qpop1($prog,1);
};

=head1 SEE ALSO

    mktdir4(1)
    A2E::Mktdir(3)
    A2E::Daba(3)
    A2E::Lokvars(3)
    nav2html(1)
    makedoksrow(1)
    perl(1)

=head1 AUTHOR

    Hartmut Pilch

=head1 COPYRIGHT

    Copyright (c) 2007-8 Hartmut Pilch (phm)

    This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=head1 IMPLEMENTATION

=head2 Overloadable functions

=head3 Function defvars

=cut

sub defvars {
    my ($m,$prog,$lihs) = shift->qlpuc('A2E::Dokfs::defvars',@_) or return;
    $m->SUPER::defvars;
    $m->daba_defvars;
    $m->svn_defvars;
    $m->lokvars_defvars;
    $m->tmplkonf_defvars($lihs);
    $m->tmplvars_defvars($lihs);
    $m->dokfs_defvars($lihs);
    $m->qpop1($prog,1);
};

=head3 Function insert_get_dok_plugin

=cut

sub insert_get_dok_plugin { # overwrite me!
    my $m = shift;
    my $plugin = shift;
    die 'unknown get_dok plugin %s', $plugin;
};

=head3 Function dokfs_lastkonfig

=cut

sub dokfs_lastkonfig {
    my ($m,$prog,$lihs) = shift->qlpuc('dokfs_lastkonfig',@_) or return;
    my ($key, $val);
  DIRURLS: {
      foreach $key (keys %{$m->{konfig}->dirurls}) {
	  next unless $key;
	  $val = $m->{konfig}->dirurls->{$key} || '';
	  ($val) = $val =~ m(\A(?:https?\:\/\/)?(?:www\.)?(.*)\Z);
	  next unless $val;
	  $m->{konfig}->urldirs->{$val} = $key;
      };
    };
  VIHDOMS: {
      $m->dpuc('vihdoms');
      foreach $key (keys %{$m->{konfig}->vihdoms}) {
	  $m->dpuc($key);
	  do { $m->dpop;next } unless $key;
	  $val = $m->{konfig}->vihdoms->{$key} || '';
	  do { $m->dpop;next } unless $val;
	  $m->dgot(vih => $key, dom => $val);
	  $m->{konfig}->domvihs->{$val} = $key;
	  $m->dpop($key);
      };
      $m->dpop('vihdoms');
    };
    $m->qpop1($prog,1);
};

=head3 Function lastkonfig

=cut

sub lastkonfig {
    my ($m,$prog,$lihs) = shift->qlpuc('A2E::Dokfs::lastkonfig',@_) or return;
    $m->SUPER::lastkonfig($lihs);
    $m->dokfs_lastkonfig($lihs);
    $m->qpop1($prog,1);
};

=head3 Function dokfs_postkonfig

=cut

sub dokfs_postkonfig {
    my ($m,$prog,$lihs) = shift->qlpuc('dokfs_postkonfig',@_) or return;
    $m->tmplkonf_postkonfig($lihs);
    $m->{progvars}->{$_} ||= $m->{konfig}->get($_) for qw(tmplang dokprogver privat); # 暫不取dok, 怕覆蓋真値
    $m->lit2mlid_kre_revers_map;
    $m->{konfig}->comment_format->{deplate} ||= '\A\%';
    $m->{konfig}->comment_format->{txt2html} ||= '\A\#';
    foreach my $conv (keys %{$m->{konfig}->comment_format}) {
	my $fmt = $m->{konfig}->comment_format->{$conv};
	$m->dpuc($conv, $fmt);
	$m->{comment_regex}->{$conv} = qr($fmt);
	$m->dpop;
    };
    for (@{$m->{konfig}->get_dok_plugins}) {
	$m->dpuc($_);
	m(\Apvar\Z) && do { $m->{get_dok_plugins}->{$_} = $m->make_pvar2dok();next };
	m(\Ameta\Z) && do { $m->{get_dok_plugins}->{$_} = $m->make_meta2dok();next };
	m(\Adir\Z) && do { $m->{get_dok_plugins}->{$_} = $m->make_dir2dok();next };
	m(\Amake\Z) && do { $m->{get_dok_plugins}->{$_} = $m->make_makefile2dok();next };
	m(\Akonfig\Z) && do { $m->{get_dok_plugins}->{$_} = $m->make_konfig2dok();next };
	$m->insert_get_dok_plugin($_);
	$m->dpop;
    };
    $m->{konfig}->lng_faylz_mul_uni(1) unless $m->dokprogverpre(404);
    $m->qpop1($prog,1);
};

=head3 Functions kre_revers_map, lit2mlid_kre_revers_map 

To be done at startup in postkonfig.

    args := lit2kol, kol2lit
    lit2kol := string
    lit2kol => 'lit2mlid'
    kol2lit := string
    kol2lit => 'mlid2lit'
    rets := revers_map

The source map is found in $m->{cache}->{lit2kol}
The target map is stored in $m->{cache}->{kol2lit}

=cut

sub kre_revers_map {
    my $prog = 'kre_revers_map';my $m = shift;$m->dpuc($prog,@_);
    my $lit2kol_nom = shift; # lit2mlid
    my $lit2kol_hac = $m->{konfig}->get($lit2kol_nom);
    return $m->Wpop0($prog, p => mapnil => n => $lit2kol_nom) unless %$lit2kol_hac;
    my $kol2lit_nom = shift; # mlid2lit
    my $kol2lit_hac = $m->{cache}->{$kol2lit_nom} || {};
    return $m->Wpop0($prog, p => hacekz => n => $kol2lit_nom, v => $kol2lit_hac) if %$kol2lit_hac;
    foreach my $nom (keys %$lit2kol_hac) { 
	$m->dpuc($nom);
	my $val = $lit2kol_hac->{$nom};
	$kol2lit_hac->{$val} = $nom;
	$m->dpop($nom);
    };
    $m->{cache}->{$kol2lit_nom} = $kol2lit_hac;
    $m->dpop1($prog,$kol2lit_hac);return $kol2lit_hac;
};
sub lit2mlid_kre_revers_map {
    return shift->kre_revers_map('lit2mlid', 'mlid2lit');
}

=head3 Function postkonfig

=cut

sub postkonfig {
    my ($m,$prog,$lihs) = shift->qlpuc('A2E::Dokfs::postkonfig') or return;
    $m->SUPER::postkonfig($lihs);
    $m->daba_postkonfig;
    $m->svn_postkonfig;
    $m->dokfs_postkonfig($lihs);
    $m->set_template_include_path(lihs => $lihs);
    $m->qpop1($prog,1);
};

=head2 Configuration Functions (overwritable)

=head3 Function html_filename

How html file names are formed when a stem and a two-letter language code are given.

The Apache configuration may have to contain the same configuration information if content negotiation is to be used effectively.

=cut

sub html_filename {
    my ($m,$prog,$stem,$lang) = shift->ppuc('html_filename',@_);
    my $html = $m->konfget('html_suffix') || 'html';
    my $fi = join '.', $stem, $lang, $html;
    $m->dpop1('html_filename', $fi);
};

=head3 Function mlid_put_mltxt

Write a document- and language-specific tag and value to the database.

arg1 is the tag (mlid), arg2 the value (mltxt).

=cut
sub mlid_put_mltxt {
    my ($m,$prog,$lihs,$mlid,$mltxt,$lang,$dok) = shift->opuc('mlid_put_mltxt',[qw(mlid text lang dok)],@_);
    my $n = $m->put('langtxts', { dok => $dok, lang => $lang, mlid => $mlid }, mltxt => $mltxt);
    $m->dpop1($prog,$n);
};

=head3 Function svnbasdirs2dir

Overwritable fallback function that specifies how dir2dir works in case the base directory is not specified in the svnbas2dir configuration option

    sig_oas, 08, 09  => /sig/oas/08/09 

=cut

sub svnbasdirs2dir {
    my ($m,$prog,$bas,@dirs) = shift->ppuc('svnbasdirs2dir',@_);
    my $dir = catdir '', split('_', $bas), @dirs;
    $m->uwarn('unreadable directory %d, obtained from unknown base %b', d => $dir, b => $bas) unless -d $dir;
    $m->dpop1($prog,$dir);
}

=head2 General Functions

possibly belong to a lower layer

=head3 Function htmlesc

Escape text for use in html

=cut

sub htmlesc {
    my $m = shift;
    $m->dpuc('htmlesc', @_);
    local $_ = shift;
    s(\&)(\&amp;)g;
    $m->dpop1('htmlesc', $_);
    return $_;
};

=head3 Function tmpltag 

Synopsis

    $p->tmpltag({ TAG_STYLE => 'star', POST_CHOMP => '-' }, 'SET', 'dummy', '=', 1);

	=> [* SET dummy = 1 -*]

    $p->tmpltag('SET', 'dummy', '=', 2);

	=> <% SET dummy = 2 %>

Arg 1 is an optional reference to a template options hash as described in Template::Manual::Config.
    
If arg 1 is not a reference, it is omitted and $m->{cache}->{tmplopts} is consulted instead.

=cut

sub tmpltag {
    my $m = shift;
    my $opts = $_[0];
    if (ref $opts) { shift } else { $opts = $m->{cache}->{tmplopts} || {} };
    my $style = $opts->{TAG_STYLE} || 'template';
    my ($left, $right) = split m(\s), $m->{konfig}->style_tags->{$style};
    my $mid = join ' ', @_;
    my $tag = $m->enclose($left.$opts->{PRE_CHOMP}.' ', ' '.$opts->{POST_CHOMP}.$right, $mid);
    return $tag;
}

=head2 Parse and write document metadata

=head3 Function url_parts

Take an URL, return a list consisting of protocol, domain and the file path (as a list of directory parts and a final filename)

=cut

sub url_parts {
    my $m = shift;
    $m->dpuc('url_parts', @_);
    my $url = shift;
  NO_URL: { $m->dpuc('no_url');do { $m->dpop;last } if $url;$m->dpop('url_parts');return };
    my ($prot, $dom, $dir) = $url =~ m(\A(\w+\:\/*)([a-z][\w\.\-]*[a-z])\b(.*)\Z);
  NO_PROT: { $m->dpuc('no_prot');do { $m->dpop;last } if $prot;$m->dpop('url_parts');return };
    my @dirs = grep {$_} splitdir $dir;
    $m->dpop('url_parts', $prot, $dom, @dirs);
    return $prot, $dom, @dirs;
};

=head3 Function set_url_parts

set the object field 'url_parts' to a reference to the list of values returned by url_parts

=cut

sub set_url_parts {
    my $m = shift;
    $m->dpuc('set_url_parts', @_);
    my $url = shift || $m->{url};
    $m->{url_parts} ||= [ $m->url_parts($url) ];
    $m->dpop1('set_url_parts', @{$m->{url_parts}});
    return @{$m->{url_parts}};
};

=head3 Function reldirs

subroutine of reldir and relurl

=cut

sub reldirs {
    my $m = shift;
    $m->dpuc('reldirs', @_);
    my $srcdirs = shift;
    my $objdirs = shift;
    my $n = 0;
    $m->dgot(srcdirs => $srcdirs, objdirs => $objdirs);
    while (1) {
	last unless length $objdirs->[$n];
	last unless length $srcdirs->[$n];
	last unless $objdirs->[$n] eq $srcdirs->[$n];
	$m->dgot(n => $n, sprintf('objdirs%d', $n) => $objdirs->[$n], sprintf('srcdirs%d',$n) => $srcdirs->[$n]);
    } continue { $n++ };
    my @reldirs = ();
    my $n_fork = $n;
    foreach $n ($n_fork..$#$srcdirs) { push @reldirs, '..' };
    foreach $n ($n_fork..$#$objdirs) { push @reldirs, $objdirs->[$n] };
    $m->dpop1('reldirs', @reldirs);
    return @reldirs;
};

=head3 Function reldir

=cut

sub reldir {
    my $m = shift;
    $m->dpuc('reldir', @_);
    my $srcdir = shift;
    my $objdir = shift;
    my @srcdirs = grep {$_} splitdir $srcdir;
    my @objdirs = grep {$_} splitdir $objdir;
    my @reldirs = $m->reldirs(\@srcdirs, \@objdirs);
    my $reldir = catdir @reldirs;
    $m->dpop1('reldir', $reldir);
    return $reldir;
};

=head3 Function relurl

Take an url and, if possible, reduce it to its url as seen from the current document $m->pvar('dok').

Example:

    $m->relurl('http://a2e.de/adv/perl/A2E/Dokfs.pm')
    # => ../perl/A2E/Dokfs.pm

=cut

sub relurl {
    my $m = shift;
    $m->dpuc('relurl', @_);
    my $url = shift;
    # $m->init_navdoks;
    $m->dgot(url => $url, m_url => $m->{url});
  NO_PARTS: {
      $m->dpuc('no_parts');
      do { $m->dpop;last } if $m->set_url_parts;
      $m->dpop1('relurl', $url);
      return $url;
  };
    $m->dgot(url_parts => $m->{url_parts});
    my ($dok_prot, $dok_dom, @dok_dirs) = @{$m->{url_parts}};
    my ($url_prot, $url_dom, @url_dirs) = $m->url_parts($url);
  NO_URL_DOM: {
      $m->dpuc('no_url_dom', $url_dom);
      do { $m->dpop;last } if $url_dom;
      $m->pwarn("couldnt parse url $url");
      $m->dpop1('relurl', $url);
      return $url;
  }
  NO_DOK_DOM: {
      $m->dpuc('no_url_dom', $dok_dom);
      do { $m->dpop;last } if $dok_dom;
      $m->pwarn("couldnt parse my own url $m->{url}");
      $m->dpop1('relurl', $url);
      return $url;
  };
  NO_DOK_URL: {
      $m->dpuc('no_dok_url', $url_dom, $dok_dom);
      do { $m->dpop;last } if $url_dom eq $dok_dom;
      $m->dpop1('relurl', $url);
      return $url;
  };
  CMP_PROT: {
      $m->dpuc('cmp_prot');
      do { $m->dpop;last } if $url_prot eq $dok_prot;
      $m->dpop1('relurl', $url);
      return $url;
  };
    my $n_fork = 0;
    while ($url_dirs[$n_fork] && $dok_dirs[$n_fork] && $url_dirs[$n_fork] eq $dok_dirs[$n_fork]) { $m->dgot(n_fork => $n_fork, url_dirs => $url_dirs[$n_fork], dok_dirs => $dok_dirs[$n_fork]);
    } continue { $n_fork++ };
    my @reldirs = ();
    $m->dgot(n_fork => $n_fork, dok_dirs => catdir(@dok_dirs), url_dirs => catdir(@url_dirs));
    my $n;
    foreach $n ($n_fork..$#dok_dirs) { push @reldirs, '..' };
    foreach $n ($n_fork..$#url_dirs) { push @reldirs, $url_dirs[$n] };
    my $relurl = catdir @reldirs;
    $m->dpop1('relurl', $relurl);
    return $relurl;
};

=head3 Function lokurl

The whole file path of the url given as argument, from the perspective of the
current $m->pvar('url'), starting from the web server\'s top directory.

=cut

sub lokurl {
    my $prog = 'lokurl';my $m = shift;$m->dpuc($prog,@_);
    my $url = shift;
    # my ($prot,$dom,$dir) = $url =~ m(\A(https?\:\/\/)?(\w[\w\.\-]+\.\w+)(\/.*)?\Z);
    my $dir = $url;
  URL2DIR: {
      last unless $url =~ m(\Ahttp);
      $dir = $m->url2dir($url);
    };
    $dir = dirname $dir if -f $dir;
    $m->uwarn('unknown lokurl dir %D', D => $dir) unless -d $dir;
    $m->dpop1($prog,$dir);return $dir;
};

=head3 Function set_url

Find info about my own url, derive further info from it and store it in me.

=cut

sub set_url {
    my ($m,$prog,$lihs,$pwd,$url,$dok) = shift->vlpuc('set_url',[qw(pwd_get url_get nom_get)],@_);
    return $m->dpop1($prog,$url) if $url;
    $m->pstop('nothing to get url from, not even dok') if !$dok;
    $m->pwarn('trying to set url with suboptimal methods');
  FYL2URL: {
      $url = $m->fayl_set_url($dok);
      last if !$url;
      return $m->dpop1($prog,$url);
    };
  DOK2URL: {
      ($url) = $m->dok2absurl($dok, lihs => $lihs);
      last if !$url;
      return $m->dpop1($prog,$url);
    };
    $m->ustop('cant set url for document %d in directory %w', d => $dok, w => $pwd);
};

=head3 Function init_navdoks

Collect and store some info that is needed for generating menus and other navigation help.

Make sure this is done only once.

=cut

sub init_navdoks {
    my ($m,$prog,$lihs) = shift->ppuc('init_navdoks',@_);
    return $m->dpop1($prog,1) if $m->{navdoks_flag};
    $m->set_alidoks;
    $m->set_topdoks($lihs);
    $m->set_topdok($lihs);
    $m->set_pwd($lihs);
    $m->setpvar(url => $m->set_url($lihs));
    $m->set_url_parts($m->{url});
    $m->{navdoks_flag} = 1;
    $m->dpop1($prog,1);
};

=head3 Function set_alidoks

read alias info from database into memory.

=cut

sub set_alidoks {
    my ($m,$prog,$lihs,%opts) = shift->opuc('set_alidoks',0,@_);
    my $force = $opts{force};
    return $m->dpop1($prog,1) if !$force and %{$m->{alidok}};
    my @reks = $m->get_records(qq{select dok, varval from doktexts where varnom = 'alias' and valsymp});
    my $i = scalar @reks;
    my ($dok, $varval);
    foreach my $rek (@reks) {
	($dok, $varval) = @$rek;
	$m->{alidok}->{$dok} = $varval;
	# $m->decho("ALIDOK von $dok ist $varval");
    };
    $m->dpop1($prog,$i);
};
sub set_alidok { my $m = shift;$m->deprek_warn('set_alidok', 'set_alidoks', @_);return $m->set_alidoks(@_); };

=head3 Function littups_put_db

Write language-specific text variables into the langtxts table.
These include the ones specified via 'special lit2mlid'.
They no longger include language-specific extensions specified with tmpltoks because these are not document-specific and thus not written into table 'langtxts' but rather, after some more complicated mapping, 'flddes'. 

    $m->littups_put_db({ tit => 'hello world', sut => 'i am greeting you', des => 'my first try', lab => 'hello' }, 'en', 'phm_salut081224'); 
    
The contents of the hashref mandatory first argument is written to the database.

Further optional arguments specify the language and the document.

=cut

sub littups_put_db {
    my ($m,$prog,$lihs,$littups,$lang,$dok) = shift->opuc('littups_put_db',[qw(littups lang dok)],@_);
    my $i = 0;
    while (my ($mlid, $mltxt) = each %$littups) {
	next unless $mlid and $mltxt;
	$m->mlid_put_mltxt($mlid, $mltxt, $lang, $dok);
    };
    $m->dpop1($prog,1);
}

=head3 Function putdoks

write subdocuments info into database

=cut

our %DOKSTYPNUMS = ( grpdoks => 2, subdoks => 3 );

=head4 Subroutine sup_dok2dir

From a parent directory generate a hashref table that maps document names to directories.
This table only provides basic dok to dir mapping of all leaf directories of a node, without regard to the hierarchy below the node.
The hierarchy info is then found by sup_dokprop

=cut
sub dir2subdirs {
    my ($m,$prog,$dir) = shift->ppuc('dir2subdirs',@_);
    opendir DIR, $dir;
    my @dirs = grep { -d $_ } map { catdir $dir, $_ } grep { m(\A\w+\Z) } readdir DIR;
    closedir DIR;
    $m->dpop($prog,@dirs);
};    
sub sup_dok2dir {
    my ($m,$prog,$sup) = shift->ppuc('sup_dok2dir',@_);
    my $radikdir = catdir '';
    $m->pstop(nildirinfo => d => $sup) unless $sup;
    $m->ustop(raidirinfo => d => $sup) if $sup eq $radikdir;
    $m->ustop(nondirinfo => d => $sup) unless -d $sup;
    $m->ustop(nordirinfo => d => $sup) unless -r $sup;
    my @dirs = $m->dir2subdirs($sup);
    my $dok2dir = {};
    foreach my $dir (@dirs) { 
	my $dok = $m->dir2dok($dir);
	next unless $dok;
	$dok2dir->{$dok} = $dir;
    };
    $m->dpop1($prog,$dok2dir);
};
sub supdir_setprops {
    my ($m,$prog,$supdir) = shift->ppuc('supdir_setprops',@_);
    my $dok2dir = $m->sup_dok2dir($supdir);
    while (my ($dok,$dir) = each %$dok2dir) { 
	$m->{dokprop}->{$dok}->{dir} = $dir;
    };
    $m->dpop1($prog,1);
};

=head4 body of putdoks

Write contents of a grpdoks/subdoks file to db.

=cut
sub dok2fol {
    my ($m,$prog,$dok) = shift->ppuc('dok2fol',@_);
    my $dir = $m->{dokprop}->{$dok}->{dir};
    $m->pstop(doknodir => d => $dok) unless $dir;
    my $fol = basename $dir;
    $m->dpop1($prog,$fol);
};
sub putdoks {
    my ($m,$prog,$dokstyp,$supdir,$supdok,@doks)= shift->ppuc('putdoks',@_); # 'subdoks','/phm/19','phm_pub19','phm_pub_ont19'
    $dokstyp ||= $m->pvar(dokstyp => 1);
    $supdok ||= $m->pvar(supdok => 1) || $m->pvar('dok');
    my $pretyp = $DOKSTYPNUMS{$dokstyp};
    $m->pstop('invalid dokstyp %t', t => $dokstyp) unless $pretyp;
    my $dirstem = $dokstyp eq 'subdoks' ? $supdir : dirname $supdir;
    $m->supdir_setprops($dirstem);
    my $pfx = $m->pvar(srcfpfx => 1);
  DOKS: {
      my $blok = 'doks';
      $m->dpuc($blok,@doks);
      do { $m->dpop;last } if @doks;
      @doks = $m->set_doks($dokstyp, DirsP => 1, dir => $supdir);
      do { $m->dpop($blok, @doks);last } if @doks;
      $m->uwarn('found no subdocuments to below document %d', d => $supdok);
      $m->dpop($prog);return;
    };
  SET_PREDOKS: {
      my $dok = pop @doks;
      $m->ustop('dok %d occurs twice in %g %k', d => $dok, g => $dokstyp, k => $m->koniug_et(@doks)) if grep { $_ eq $dok } @doks;
      my $predok = '';
      my $n = 0;
    PRE: {
	$predok = pop @doks;
	last unless $predok;
	$m->ustop('predok %p occurs twice in %t %D', p => $predok, t => $dokstyp, D => $m->koniug_et(@doks)) if grep { $_ eq $predok } @doks;
	$m->put(mlhtdok => { dok => $predok }, doktmp => 'now()');
	#150321 $n = $m->sql_query(qq{update dokprop set predok = null, pretyp = 0 where predok = '$predok' and pretyp = 1});
	$m->upd(dokprop => { predok => $predok, pretyp => 1 }, predok => '') ;
	#150321 $m->decho("UPDATE $n");
	$m->put(mlhtdok => { dok=> $dok }, doktmp=> 'now()');
	$m->put(dokprop => { dok => $dok }, pretyp => 1, predok => $predok, doknom => $m->dok2fol($dok));
	$dok = $predok;
	redo;
      };
      #150321 $n = $m->sql_query(qq{update dokprop set predok = null, pretyp = 0 where predok = '$supdok' and pretyp = $pretyp});
      $m->upd(dokprop => { predok => $supdok, pretyp => $pretyp }, predok => '');
      #150321 $m->decho("UPDATE $n");
      $m->put(mlhtdok => { dok=> $dok }, doktmp=> 'now()');
      $m->put(dokprop => { dok => $dok }, pretyp => $pretyp, predok=> $supdok, doknom => $m->dok2fol($dok));
    };
    $m->dpop1($prog,1);
};

=head3 Function set_topdoks

Read from database which document nodes are root nodes (topdoks), and store this info in the object $m as follows.

Any document node $dok that has no other node above itself is marked with
$m->{topdoks}->{$dok} = 1.

Return the number of topdoks thus found.

This should come near the beginning of most programs that use A2E::Dokfs.

Many other routines depend on the info being set.  Unless given a true first argument ($force), it returns without reading the database anew (in the topdoks_already_set block) if it finds that the topdoks info is already there.

Another method of finding out whether a given dok directory is at the top of a microsite is provided by function topinddokp.

=cut

sub set_topdoks {
    my ($m,$prog,$lihs,%opts) = shift->lpuc('set_topdoks',@_);
    my $force = $opts{force};
    return $m->dpop1($prog,1) if !$force and $m->ref2hash($m->{topdoks});
    my @reks = map { $_->[0] } $m->get_records(qq{select topdok from topdok});
    my $i = scalar @reks;
    foreach my $rek (@reks) {
	$m->{topdoks}->{$rek} = 1;
    };
    $i += $m->set_inddoks($lihs, force => 1);
    $m->dpop1($prog,$i);
};

sub set_inddoks {
    my ($m,$prog,$lihs,%opts) = shift->lpuc('set_inddoks',@_);
    my $force = $opts{force};
    return $m->dpop1($prog,1) if !$force and $m->ref2hash($m->{inddoks});
    my @reks = map { $_->[0] } $m->get_records(qq{select inddok from inddok});
    my $i = scalar @reks;
    foreach my $rek (@reks) {
	$m->{inddoks}->{$rek} = 1;
    };
    $m->dpop1($prog,$i);
};

=head3 Function alidok

return the final document identifier to which a chain of aliases may be pointing.

=cut

sub alidok {
    my ($m,$prog,$lihs,$dok) = shift->opuc('alidok',[qw(nom_let)],@_);
    return $m->dpop($prog) if !$dok;
    my $alidok;
    my @doks = ($dok);
    my %dokp = ($dok => 1); 
    $m->set_alidoks(lihs => $lihs);
  SETALIDOK: {
      $alidok = $m->{alidok}->{$dok};
      last unless $alidok;
      $m->ustop(infinilup => L => \@doks, e => $alidok) if $dokp{$alidok};
      $dok = $alidok;push @doks, $dok;$dokp{$dok} = 1;
      redo;
    };
    $m->dpop1($prog,$dok);
};

=head2 Document identifier URL Scheme

In the good old days of txt2html, we used to write [dok:a2edb_perl_pub], like a kind of URL in analogy for [http://a2e.de/adv/perl/A2E].

This is poorly documented and mostly unused now because we are relying on a more programmable formatter, deplate, which encourages different solutions.

=head3 Function relurltit_url2dokfol


dok: registered document identifier
fol: leaf, file which is found in the directory

=cut

sub relurltit_url2dokfol {
    my ($m, $url) = @_;
    $m->decho("relurltit_url2dokfol url: $url");
    my ($dok, $fol);
  PFX_DOK: {
      last unless ($dok) = $url =~ m(\Adok\:([\w\_]+)\Z);
      return $dok;
  };
  PFX_DOK_FOL: {
      last unless ($dok, $fol) = $url =~ m(\Adok:([\w\_]+)\/(.*)\Z);
      return $dok, $fol;
  };
  DOK: {
      last unless ($fol) = $url =~ m(\A([\w\_]+)\Z);
      return '', $fol if -r $fol;
      return $fol;
  };
  DOK_FOL: {
      last unless ($dok, $fol) = $url =~ m(\A([\w\_]+)\/(.*)\Z);
      return '', $url if -r $dok;
      return $dok, $fol;
  };
};

=head3 Function relurltit

=cut

sub relurltit {
    my $m = shift;
    $m->dpuc('relurltit', @_);
    my $url = shift;
    my $tit = shift;
    my ($dok, $fol) = $m->relurltit_url2dokfol($url);
    $m->dgot(dok => $dok, fol => $fol);
    my ($relurl, $prot);
    if ($dok) {
	$tit = catdir $dok, $fol unless $tit;
	($relurl) = $m->dok2relurl($dok);
	$relurl = catdir $relurl, $fol;
    } elsif ($fol) {
	$relurl = $fol;
    } else {
	($prot, $relurl) =  $url =~ m(\A(href|file)\:(\S+)\Z);
    };
    $url = $relurl || $url;
    $tit = $tit || $url;
    my $rel = $relurl ? 1 : 0;
    $m->dpop('', $rel, $url, $tit);return $rel, $url, $tit;
};

=head3 Function ahref

=cut

sub ahref {
    my $m = shift;
    $m->dpuc('ahref', $@);
    my ($rel, $url, $tit) = $m->relurltit(@_);
    $tit = $m->htmlesc($tit) if $m->{konfig}->htmlesc;
    my $ahref = sprintf q{<a href="%s">%s</a>}, $url, $tit;
    $m->dpop1('ahref', $ahref);return $ahref;
};

=head3 Function ahref_item

=cut

sub ahref_item {
    my $m = shift;
    $m->dpuc('ahref_item', @_);
    my $item = $m->listitem($m->ahref(@_));
    $m->dpop1('ahref_item', $item);return $item;
}

=head3 Function hreftext

Used in generating menus

=cut

sub hreftext {
    my $m = shift;
    $m->dpuc('hreftext', @_);
    my $href = shift;
    my $text = shift;
    $text = $href ? "<a href=\"$href\">$text</a>" : $text;
    $m->dpop1('hreftext', $text);return $text;
}

=head3 Function imgurltit

=cut

sub imgurltit {
    my $m = shift;
    $m->dpuc('imgurltit', @_);
    my ($rel, $url, $tit) = $m->relurltit(@_);
    my $res = sprintf q{<img src="%s" alt="%s"/>}, $url, $tit;
    $m->dpop1('imgurltit', $res);return $res;
}

=head3 Function url2dok

=cut

sub url2dok {
    my $m = shift;
    $m->dpuc('url2dok', @_);
    my $url = shift;
    my ($dok) = $url =~ m(\Adok:(\w+)\Z);
    do { $m->dpop1('url2dok', $dok);return $dok } if length $dok;
    my ($sub) = $url =~ m(\A(\w+)\Z);
    do { $m->dpop('url2dok');return } unless length $sub;
    my $html = $m->konfget('html_suffix');
    do { $m->dpop('url2dok');return } if -r $sub or -r join('.', $sub, $html)  or -r $m->html_filename($sub, $m->{lang});
    $m->dpop1('url2dok', $sub);return $sub;
};

=head3 Function x2urllab

=cut

sub x2urllab {
    my $m = shift;
    $m->dpuc('x2urllab', @_);
    my $url = shift;
    my $tit = shift;
    my ($dok) = $m->url2dok($url);
    if ($dok) {
	my ($db_url, $db_tit) = $m->dok2urllab($dok);
	$url = $db_url || $url;
	$tit = $tit || $db_tit;
    };
    $tit = $tit ? $m->htmlesc($tit) : $url;
    $m->dpop('x2urllab', $url, $tit);return $url, $tit;
};

=head2 Generate hyperlinks from document identifiers

These are needed by menu-generating programs such as nav2html and makedoksrow.

=head3 Function get_langtxt

Get a chunk of text, specifying the mlid (identifier, e.g. 'label') and optionally dok, lang and uid.  Usually the latter three are preset.

=cut

sub get_langtxt {
    my $m = shift;
    $m->dpuc('get_langtxt', @_);
    my $mlid = shift;
    my $dok = shift || $m->set_dok;
    my $lang = shift || $m->{lang};
    my $uid = shift || $m->{autor};
    my $mltxt = '';
    ($mltxt) = $m->get_record('langtxts', { dok => $dok, lang => $lang, mlid => $mlid }, 'mltxt');
    $m->dpop1('get_langtxt', $mltxt);
    return $mltxt;
};

=head3 Function lit2mlid

convert 'lab' to 'label' etc, using the user-specified lit2mlid hash

=cut

sub lit2mlid {
    my ($m,$prog,$lit) = shift->ppuc('lit2mlid',@_);
    my $mlid = $m->{cache}->{lit2mlid}->{$lit} || $lit;
    $m->dpop1('lit2mlid', $mlid);
}

=head3 Function mlid2lit

convert 'label' to 'lab', etc using the reverse index of the user-specified lit2mlid hash

=cut

sub mlid2lit {
    my ($m,$prog,$mlid) = shift->ppuc('mlid2lit',@_);
    my $lit = $m->{cache}->{mlid2lit}->{$mlid} || $mlid;
    $m->dpop1('mlid2lit',$lit);
}

=head3 Function get_mltxt

Like get_langtxt, but first convert with lit2mlid so that 'lab', 'sut' etc can be used

=cut

sub get_mltxt {
    my ($m,$prog,$lit) = shift->ppuc('get_mltxt',@_);
    my $mlid = $m->lit2mlid($lit);
    my $mltxt = $m->get_langtxt($mlid, @_);
    $m->dpop1($prog,$mltxt);
};

=head3 Function get_langtxt_lab

Return the label, normally in the current language and of the current document, but optionally taking dok and lang as arguments.

=cut

sub get_langtxt_lab {
    my $m = shift;
    $m->dpuc('get_langtxt_lab', @_);
    my $mltxt = $m->get_langtxt('label', @_);
    $m->dpop1('get_langtxt_lab', $mltxt);
    return $mltxt;
}

=head3 Function get_langtxt_tit

Return the title, normally in the current language and of the current document, but optionally taking dok and lang as arguments.

=cut

sub get_langtxt_tit {
    my $m = shift;
    $m->dpuc('get_langtxt_tit', @_);
    my $mltxt = $m->get_langtxt('title', @_);
    $m->dpop1('get_langtxt_tit', $mltxt);
    return $mltxt;
}

=head3 Function get_langtxt_sut

Return the subtitle, normally in the current language and of the current document, but optionally taking dok and lang as arguments.

=cut

sub get_langtxt_sut {
    my $m = shift;
    $m->dpuc('get_langtxt_sut', @_);
    my $mltxt = $m->get_langtxt('subtitle', @_);
    $m->dpop1('get_langtxt_sut', $mltxt);
    return $mltxt;
}

=head3 Function get_langtxt_des

Return the description, normally in the current language and of the current document, but optionally taking dok and lang as arguments.

=cut

sub get_langtxt_des {
    my $m = shift;
    $m->dpuc('get_langtxt_des', @_);
    my $mltxt = $m->get_langtxt('descr', @_);
    $m->dpop1('get_langtxt_des', $mltxt);
    return $mltxt;
}

=head3 Function dok2urllab

take document identifier (dok), return url and label

=cut

sub dok2urllab {
    my $m = shift;
    $m->dpuc('dok2urllab', @_);
    my $dok = shift || '';
    my $lab = shift || '';
    do { $m->dpop;return } unless length $dok;
    $dok = $m->pvar('topdok') if $dok eq '_topdok';
    my ($ok);
  NO_DOK: {
      $ok = length $dok ? 0 : 1;
      $m->dpuc('no_dok', $ok, $dok);
      do { $m->dpop;last } unless $ok;
      $m->dpop('dok2urllab');return;
    };
    $dok = $m->alidok($dok);
    my $url = $m->{dokurl}->{$dok} || '';
    $lab = $m->{doklab}->{$dok} || '';
    $m->dgot(dok => $dok, url => $url, lab => $lab);
    do { $m->dpop('dok2urllab', $url, $lab);return $url, $lab } if length $url and length $lab;
    ($url) = $m->dok2absurl($dok);
    do { $m->dpop('dok2urllab');return } unless length $url;
  SET_URL: {
      $m->dpuc('set_url', $url);
      do { $m->dpop;last } if $url =~ m(\Afile\:);
      $url = $m->relurl($url);
      $m->dpop;
  };
  SET_LAB: {
      $m->dpuc('set_lab', $lab);
      do { $m->dpop1('set_lab', $lab);last } if $lab;
      ($lab) = $m->get_langtxt('label', $dok);
      do { $m->dpop1('set_lab', $lab);last } if $lab;
      ($lab) = $m->get_record('dokprop', { dok => $dok }, 'doknom');
      do { $m->dpop1('set_lab', $lab);last } if $lab;
      ($lab) = $url =~ m(\A.*\/(\w+)\/?\Z);
      $m->dpop1('set_lab', $lab);
    };
    $m->{doklab}->{$dok} = $lab if $lab;
    $m->{dokurl}->{$dok} = $url;
    $m->dpop('dok2urllab', $url, $lab);return $url, $lab;
};

=head3 Function doklangs

Return sequence of preferred languages for linking, based on what the user indicated, what the
current document uses and what the target document $dok allows.

=cut

sub doklangs {
    my ($m,$prog,$dok,@arglangs) = shift->ppuc('doklangs',@_);
    my %arglangp = ();
    $arglangp{$_} = 1 for @arglangs;
    my $lang = $m->pvar(lang => 1);
    my @doklangs = $m->get_langs(dok => $dok);
    if (grep { $lang eq $_ } @doklangs) { @doklangs = ($lang, grep { $lang ne $_ } @doklangs) };
    my %doklangp = ();
    $doklangp{$_} = 1 for @doklangs;
    my @langs = ();
    if (@arglangs) {
	do { next unless $doklangp{$_};push @langs, $_ } for @arglangs;
    } else {
	@langs = @doklangs;
    };
    $m->dpop($prog,@langs);
};

=head3 Function relspe2rekmap

Based on a relation specifier such as

  adr:person,postkod:sdeplz,urb:sdeurb,urber:sdeurb2,strad:sdestr,strader:sdestr2,dom:sdedom,domer:sdedom2,adrrem:sdearem

return a tree containing the info needed to construct sql-based put/get queries from vocabulary data.

In the a2e_perl_ebnf (a2e-perl-adapted Extended Backus Naur Form) notation, the input and ouput of this function can be explained as follows:

    args :: arguments
    args := relspe
    relspe :: relation specifier
    rets :: return values
    rets := rekmap
    rekmap :: database_record_info
    relspe => [ [ 'adr', 'person' ], [ 'postkod', 'plz' ], [ 'urb' ], [ 'urber', 'urb2' ], [ 'strad', 'str' ], [ 'strader', 'str2' ], [ 'dom' ], [ 'domer', 'dom2' ], [ 'adrrem', 'rem' ] ];
    relspe := listref(rekide, fldspe+)
    rekide :: record identifier
    rekide => [ 'adr', 'person' ]
    rekide => [ 'traprop', 'dok', 'lit','lang' ]
    rekide := listref(tab, idekol+)
    fldspe :: field specifier
    fldspe => [ 'postkod', 'plz' ]
    fldspe := listref(kol, lit?)
    kol :: column name
    kol => 'postkod'     
    kol := symbol
    lit :: textchunk name
    lit => 'plz'
    lit := symbol
    tab :: table
    tab => 'adr'
    tab := symbol
    ikdekol :: name of identificatory column
    idekol => 'person'
    idekol := symbol
    symbol := string(symchar+)
    symchar := char(a-z,A-Z,0-9,_)
    rekmap => [ 'adr', [ 'person' ], [ 'urb', 'str', 'dom' ], { dom => 'sdom', person => 'user' } ]
    rekmap := listref(tab, idekols, atrkols, column_textchunk_map)
    idekols :: identifying columns 
    atrkols :: attributive columns
    atrkols => [ 'urb', 'str', 'dom' ]
    atrkols := listref(atrkol+) 
    atrkol :: attributive column
    atrkol => 'urb'
    atrkol := symbol
    kollits :: column_textchunk_map
    kollits => { dom => 'sdom', person => 'user' }
    kollits := hashref((kol, lit)+)

=cut

sub relspe2rekmap {
    my ($m,$prog,$relspe) = shift->ppuc('relspe2rekmap',@_);
    return $m->dpop($prog) unless $relspe;
    $m->pstop('relspe must be a listref but is %r', r => $relspe) unless 'ARRAY' eq ref $relspe;
    my ($rekide, @fldspes) = @$relspe;
  REKIDE: {
      last if 'ARRAY' eq ref $rekide;
      $m->pwarn('rekide should be a listref but begins as %r', r => $rekide);
      $rekide = $m->textsep2listref($rekide);
      last if 'ARRAY' eq ref $rekide;
      $m->pstop('rekide must be a listref but is %r', r => $rekide);
    }; 
    $m->pstop('could not find any field descriptors in relation descriptor %r', r => $relspe) unless @fldspes;
    my $tab = '';
    my $idekols = []; 
    ($tab, @$idekols) = @$rekide; # table, identificatory_column_name+
    $m->pstop('could not find any index columns in record identifier %r', r => $rekide) unless @$idekols;
    my $atrkols = []; # attributive columns
    my $kollits = {}; # columns to variable map
    my %kolfini = (); # not push my keys to the @atrkols list from now on
    $kolfini{$_} = 1 for @$idekols; # do not put identificatory columns on @atrkols
    my $kol = '';
    my $val = '';
    foreach my $fldspe (@fldspes) { # process each field_specification
	if ('ARRAY' eq ref $fldspe) {
	    ($kol, $val) = @$fldspe;
	} elsif (not ref $fldspe) {
	    $kol = $val = $fldspe;
	} else {
	    $m->pstop('fldspe must be a listref but is %f', f => $fldspe) unless 'ARRAY' eq ref $fldspe;
	};
	$kollits->{$kol} = $val if $val;
	push @$atrkols, $kol unless $kolfini{$kol};
	$kolfini{$kol} = 1;
    };
    my $rekmap = [ $tab, $idekols, $atrkols, $kollits ];
    $m->dpop1($prog,$rekmap);
};

=head3 Function tmpl2dabalits

    args := tmpl, nonlit+
    nonlit :: excluded textchunk

return a listref with all the language variables (lits) corresponding to all the database relations that are tied to a given document type (tmpl).
Arg2ff is a list of excluded lits.

=cut

sub tmpl2dabalits {
    my ($m,$prog,$lihs,$tmpl,@nonlits) = shift->lpuc('tmpl2dabalits', @_);
    $tmpl ||= $m->pvar('tmpl') || $m->pstop(funnovar => v => 'tmpl');
    my @dabalits = ();
    my %litfini = ();
    foreach my $lit (@nonlits) { $litfini{$lit} = 1 };
    my @tmplrels = eval { @{$m->nom2xlst('_tmplrels_',$lihs)} };
    return $m->dpop($prog) unless @tmplrels;
    my $dabarels = $m->nom2xhac('__dabarels__',$lihs);
    foreach my $rel (@tmplrels) {
	my $relspe = $dabarels->{$rel};
	$m->ustop('unknown relation %r', r => $rel) unless $relspe;
	my $rekmap = $m->relspe2rekmap($relspe) or $m->pstop('could not obtain a rekmap from relspe %r', r => $relspe);
	my ($tab, $idekols, $atrkols, $kollits) = @$rekmap;
	foreach my $kol (@$idekols, @$atrkols) {
	    my $kollit = $kollits->{$kol};
	    my $lit = $kollit || $kol;
	    push @dabalits, $lit unless $litfini{$lit};
	    $litfini{$lit} = 1;
	};
    };
    $m->dpop($prog, @dabalits);
};
=head3 $val = $m->littups_get($lit,$littups,$grup?): read value of a table field from section variables or identificatory section name

littups :: section variables, obtained e.g. by file:/adv/perl/A2E/Dokdata2db.pm::grupputdb
grup :: identificator section name

=cut
sub littups_get { # file:/phm/18/09/01/sig/_lng.phm_pub_sig180901.txt
    my ($m,$prog,$lit,$littups,$grup) = shift->ppuc('littups_get',@_);
    my $val = $littups->{$lit} || $grup;
    $m->dpop1($prog,$val);
};

=head3 $putrek = $m->rellits2putrek($lihs,$vahr,$relspe,%opts{littups,grup}): Obtain full info that can be put into a record of the global database.

In the a2e_perl_ebnf (a2e-perl-adapted Extended Backus Naur Form) notation:

    args := relspe, littups
    relspe :: relation specifier
    relspe => [ [ 'traprop', 'dok', 'lang' ], 'prelang', [ 'tranom', 'lfol' ], [ 'trauid', 'user' ], [ 'tradat', 'hodie' ], [ 'travers', 'ver' ] ]
    relspe <= relspe2rekmap
    littups :: textchunks to be used as template variables, named as in vocabulary files
    littups := hashref((litnom, litval)+)
    rets :: return values
    rets := putrek
    putrek :: info that can be passed to $m->put so as to put the record into the database
    putrek => [ 'traprop', { lang => 'de', dok => 'hrjaN3' }, 'trauid', 'nist', 'tradat', '2010-03-31' ]
    idelits => [ 'dok', 'lang' ]
    idelits :: identifier variables
    idelits := listref(litnom+)	
    putrek := listref(tab, ideflds, atrflds)
    ideflds :: identifying_fields
    atrflds :: describing_fields
    ideflds := hashref((fldnom, fldval)+)
    atrflds := hashref((fldnom, fldval)+)

Uses relspe2rekmap to parse this data, as does rellits2getrek

=head4 $m->rellits2putrek($lihs,$vahr,$relspe,%opts{littups,grup})

rekmap :: file:/phm/19/09/10/sig/_log07adv.txt::309686
littups :: file:/phm/19/09/10/sig/_log07adv.txt::309706
grup :: KernVie
(\@idekols,\@atrkols,\%$kollits) = @$rekmap

=cut
sub rellits2putrek { # file:/phm/19/09/10/sig/_log07adv.txt::309681
    my ($m,$prog,$lihs,$vahr,$rekmap,$littups,$grup) = shift->vlpuc('rellits2putrek',[[qw(rel2map)],[qw(littups grup)],{ grup => 'text_let' }],@_);
    my $tab = shift @$rekmap or $m->pstop('couldnt obtain table info from rekmap %r', r => $rekmap); # 'person'
    my $idekols = shift @$rekmap or $m->pstop('couldnt obtain idekols info from rekmap %r of table %t', r => $rekmap, t => $tab); # ['person']
    my $atrkols = shift @$rekmap or $m->pstop('couldnt obtain atrkols info from rekmap %r of table %t with idekols %I', r => $rekmap, t => $tab, I => $idekols); # ['persnm','persdes','lok', .... ] file:/phm/19/09/10/sig/_log07adv.txt::309729 
    my $kollits = shift @$rekmap or $m->pstop('couldnt obtain kollits info from rekmap %r of table %t with idekols %I and atrkols %A', r => $rekmap, t => $tab, I => $idekols, A => $atrkols); # mapping table file:/phm/19/09/10/sig/_log07adv.txt::309743
    my %idetups = (); # identificatory tuples
    my %atrtups = (); # attributive tuples
    # my $idelits = []; # names of text chunks that must be written to the database so that they are available for dok2data/dokrek later; OBSOLETE?
    # klunky multidimentional id should be replaced by subsections; /phm/18/09/01/sig/_lng.phm_pub_sig180901.txt
    my @idevals = split '_', $grup; # as many parts as identificatory columns @$idekols: ('KernVie')
    my $set_idetups = sub { # set identificatory tuples, return 1 if OK, error listref otherwise
	foreach my $idekol (@$idekols) {
	    my $idelit = $kollits->{$idekol};
	    my $lit = $idelit || $idekol;
	    my $ideval = shift @idevals;
	    my $val = $m->littups_get($lit,$littups,$ideval);
	    return [u => 'giving up on table %t because identificatory column %i aka variable %l has no value', i => $idekol, l => $lit, t => $tab] if !$val;
	    # push @$idelits, $lit;
	    $idetups{$idekol} = $val };
	1 };
    my $fru = &$set_idetups;
    return $m->wpop($prog,$fru) if 'ARRAY' eq ref $fru;
    my $set_atrtups = sub {
	foreach my $atrkol (@$atrkols) {
	    my $atrlit = $kollits->{$atrkol}; # file:/phm/19/09/10/sig/_log07adv.txt::309830
	    my $lit = $atrlit || $atrkol; # 'tit'
	    my $val = $m->littups_get($lit,$littups);
	    next unless $val; # it doesnt matter if an attributive field remains empty, it is enough if we have one tuple in the end
	    $atrtups{$atrkol} = $val };
	1 };
    &$set_atrtups;
    return $m->Wpop0($prog, d => noatrtups => K => [ keys %idetups ], V => [ values(%idetups) ], t => $tab) if !%atrtups;
    my $putrek = [ $tab, \%idetups, %atrtups ];
    $m->dpop1($prog,$putrek);
};

=head3 ($getrek,$kollits) = $m->rellits2getrek($relspe,$littups)

Obtain full info that can be put into a record of the global database.

Input and parsing is like in rellits2putrek.

Output is like in rellits2putrek, but with
  a smaller first return value
    column names instead of column tuples
 and with a second return value.

Here is the synopsis in a2e_perl_ebnf:

    args := relspe, littups
    rets := getrek, kollits
    getrek :: arguments suitable for &A2E::Daba::get_record 
    littups := hashref((litnom, litval)+)
    kollits :: column-textchunk map
    getrek := tab, idetups, atrkols
    tab :: table
    idetup :: identificatory tuple
    atrkol ::  attributive column
    idetup :=  idekol, ideval
    idetups := hashref(idetup+)
    atrkols := listref(atrkol+)
    idekol :: id column name 
    ideval :: id column value
    getrek => [ 'traprop', { lang => 'de', dok => 'oas_akt1003' }, [ 'prelang', 'tranom', 'trauid', 'tradat', 'travers' ] ]
    kollits => { trauid => 'user', prelang => 'prelang', tranom => 'lfol', travers => 'ver', tradat => 'hodie' }

=cut

sub rellits2getrek {
    my ($m,$prog,$lihs,$rekmap,$littups) = shift->opuc('rellits2getrek',[qw(rel2map littups)],@_);
    my $tab = shift @$rekmap or $m->pstop('couldnt obtain table info from rekmap %r', r => $rekmap);
    my $idekols = shift @$rekmap or $m->pstop('couldnt obtain idekols info from rekmap %r of table %t', r => $rekmap, t => $tab);
    my $atrkols = shift @$rekmap or $m->pstop('couldnt obtain atrkols info from rekmap %r of table %t with idekols %I', r => $rekmap, t => $tab, I => $idekols);
    my $kollits = shift @$rekmap or $m->pstop('couldnt obtain kollits info from rekmap %r of table %t with idekols %I and atrkols %A', r => $rekmap, t => $tab, I => $idekols, A => $atrkols);
    my %idetups = (); # identificatory tuples to be set
    foreach my $idekol (@$idekols) {
	my $idelit = $kollits->{$idekol};
	my $lit = $idelit || $idekol;
	my $val = $m->littups_get($lit,$littups,lihs => $lihs);
	return $m->Wpop0($prog, d => idenoval => i => $idekol, l => $lit, t => $tab) if !$val;
	$idetups{$idekol} = $val;
    };
    my $getrek = [ $tab, \%idetups, $atrkols ];
    $m->dpop($prog,$getrek,$kollits);
};

=head3 $data = $m->dok2relsdata($dok,$data?): Retrieve the document's metadata from the rdb tables indicated with the special tmplrels directive.

    args := dok, data
    rets := data
    data := hashref((nom, val)+)
    data :: initial data tuples on their way to become complete littups

Do not retrieve anything from dbm files -- that is done on a higher level in &A2E::MLHT::tmplvars_kk_dbmvars 

=cut

sub dok2relsdata {
    my ($m,$prog,$lihs,$dok,$data) = shift->opuc('dok2relsdata',[qw(dok data), { data => 'hacr_get' }],@_);
    my @rels = eval { @{$m->nom2xlst('_tmplrels_')} };
    my $dabarels = $m->nom2xhac('__dabarels__');
    foreach my $rel (@rels) {
	my $relspe = $dabarels->{$rel};
	$m->ustop('unknown relation %r', r => $rel) unless $relspe;
	my ($getrek, $kollits) = $m->rellits2getrek($relspe, $data);
	do { $m->decho('relation specification %r was not applicable', r => $relspe);next } unless $getrek;
	my ($tab, $idetups, $atrkols) = eval { @$getrek };
	do { $m->pwarn('wrong get_record info %r', r => $getrek);next } unless 'ARRAY' eq ref $atrkols;
	do { $m->pwarn('wrong kollits info %K', K => $kollits);next } unless 'HASH' eq ref $kollits;
	my (@vals) = $m->get_record(@$getrek);
	foreach my $kol (@$atrkols) {
	    my $val = shift @vals;
	    next unless $val;
	    my $lit = $kollits->{$kol} || $kol;
	    $data->{$lit} = $val;
	};
    };
    $m->dpop1($prog,$data);
};

=head3 Function get_dokdata_cache_rek

Return a pointer to a hash that contains cached document metadata, conventionally called $data and pointing to $m->{dokreks}->{$dok}->{$lang}, functioning as a handle for reading and writing.

If caching is turned off by means of the --dokdata_cache option, just return an empty hashref.
 
=cut

sub get_dokdata_cache_rek {
    my $prog = 'get_dokdata_cache_rek';my $m = shift;$m->dpuc($prog,@_);
    my ($dok,$lang) = @_;
    my $data = eval { $m->{dokreks}->{$dok}->{$lang} } || {};
    if ($data) { $m->dpop1($prog,$data);return $data };
    $m->{dokreks} ||= {};
    $m->{dokreks}->{$dok} ||= {};
    $m->{dokreks}->{$dok}->{$lang} ||= {};
    $data = $m->{dokreks}->{$dok}->{$lang};
    $m->dpop1($prog,$data);return $data;
};

=head3 Function dok2data

Similar to dok2urllab, but return a hash of all the language-dependent metadata found in the database

    args := dok, lang
    rets := littups

=cut
sub dir2langs {
    my ($m,$prog,$dir) = shift->ppuc('dir2langs');
    my $bl = $m->hsprintf('%plangs');;
    my $fl = catfile $dir, $bl;
    return $m->Wpop0($prog, p => nofyl => f => $fl) unless -r $fl;
    my $sl = $m->fayl_get_str($fl,1);
    my ($sls) = split "\n", $sl;
    my @langs = split m(\W), $sls;
    $m->dpop($prog,@langs);
};    
sub dok2data {
    my ($m,$prog,$dok,$lang,%opts) = shift->ppuc('dok2data',@_);my $lihs = $m->get_lihs($opts{lihs});$opts{lihs} = $lihs;
    ($dok, my $dir) = $m->setdokdir($dok,$opts{dir});
    $m->pstop('dok2data without a document identifier to work on') unless $dok;
  LANG: {
      last if $lang;
      $m->pwarn('no lang given, trying system variables');
      $lang = $m->pvar('lang') || $lihs->getstr('__lang');
      last if $lang;
      $m->pwarn('no lang found, looking for first language of directory %d', d => $dir);
      ($lang) = $m->dir2langs($dir);
      last if $lang;
      $m->pstop('cant determine in what language to search');
    };
    my $data = $m->get_dokdata_cache_rek($dok, $lang) || {};
    $data->{dok} = $dok;
    $data->{lang} = $lang;
    do { $m->dpop1($prog, $data);return $data } if $data->{url} and $data->{lab} and $data->{nom} and $data->{tit};
    $data->{lab} = $m->{doklab}->{$dok} || '';
    $data->{url} = $m->dok2lokurl($dok, lang => $lang, dir => $dir, url => $opts{url});
  SET_DOKDATA: {
      my @reks = $m->get_records('langtxts', { dok => $dok, lang => $lang }, qw(mlid mltxt));
      foreach my $rek (@reks) {
	  my ($mlid, $mltxt) = @$rek;
	  my $lit = $m->mlid2lit($mlid);
	  next if $data->{$lit};
	  $data->{$lit} = $mltxt;
      };
      ($data->{doknom}, $data->{datum}, $data->{tmpl}, $data->{lastmod}, $data->{moddist}, $data->{smprior}, $data->{privat}) = $m->get_record('dokprop', { dok => $dok }, qw(doknom dokdatum doktyp lastmod moddist smprior privat));
    NOM: {
	last; # the following should be obsolete since we have 'special dabarel lang' 2010-04-08
	($data->{nom}) = $m->get_record('traprop', { dok => $dok, lang => $lang }, qw(tranom));
	last if $data->{nom};
	$data->{nom} = $data->{doknom};
	last if $data->{nom};
	($data->{nom}) = $data->{url} =~ m(\A.*\/(\w+)\/?\Z);
      };
      $data->{lab} ||= $data->{nom};
    };
    $data->{top} = $m->{topdoks}->{$dok};
    $m->{doklab}->{$dok} = $data->{lab} if $data->{lab};
    $m->{dokurl}->{$dok} = $data->{url};
    delete $data->{doknom};
    $data->{lastmod} ||= $data->{datum};
    delete $data->{datum};
    $data->{dok} = $dok;
    $data->{lang} = $lang;
    $data = $m->dok2relsdata($dok, $data);
    $m->ustop('document metadata of %d contained indication that dok is %D', d => $dok, D => $data->{dok}) unless $dok eq $data->{dok};
    $m->ustop('document metadata of %d in lang %l contained indication that lang is %L', d => $dok, l => $lang, L => $data->{lang}) unless $dok eq $data->{dok};
    $m->dpop1('dok2data', $data);
    return $data;
};

=head3 Function db_dok2absurl

retrieve document's url from database.

subroutine of dok2absurl.

=cut

sub db_dok2absurl ($$) {
    my ($m,$prog,$lihs,$dok,%opts) = shift->opuc('db_dok2absurl',[qw(nom)],@_);
    my ($url) = $m->get_record(mlhtdok => { dok=> $dok }, 'dokurl');
    $m->dpop1($prog, $url);
};
sub db_absurl { my $m = shift;$m->deprek_warn('db_absurl', 'db_dok2absurl', @_);return $m->db_dok2absurl(@_) }

=head3 Function dokurls

return both absolute and relative url for dok, where dok is a document symbol with an optionally appended relative pathname

=cut

sub dokurls {
    my ($m,$prog,$s,$lihs) = shift->ppuc('dokurls',@_);local $_ = $s;$lihs = $m->get_lihs($lihs);
    my ($dok, $rest) = m(\A(\w+)(.*)\Z);
    $m->set_alidoks(lihs => $lihs);
    $dok = $m->alidok($dok,lihs => $lihs);
    my $absurl = $m->dok2absurl($dok, lihs => $lihs);
    my $relurl = $m->lokurl($absurl,$lihs) . $rest;
    $absurl .= $rest;
    $m->dpop($prog,$absurl,$relurl);
};

=head3 Function dok2relurl

take dok, return url, as relative as possible, as short as possible (only directory, without full filename 'index*.html', if the rest can be handled by content negotiation)

=cut

sub dok2relurl {
    my ($m,$prog,$dok) = shift->ppuc('dok2relurl',@_);
    my ($absurl, $relurl) = $m->dokurls($dok);
    $m->dpop1($prog,$relurl);
};
sub dokurl { my $m = shift;$m->deprek_warn('dokurl', 'dok2relurl', @_);return $m->dok2relurl(@_) }

=head3 $lokurl = $m->dok2lokurl($dok,dir,lang,%opts{lihs,vahr,url})

take dok, return url, as relative as possible, as short as possible (only directory, without full filename 'index*.html', if the rest can be handled by apache content negotiation)

=cut

sub dok2lokurl {
    my ($m,$prog,$lihs,$dok,$dir,$lang,$url,%opts) = shift->opuc('dok2lokurl',[[qw(nom3_get)],[qw(dir_let lang_let url_let)]],@_);
    ($dok, my $rest) = $dok =~ m(\A(\w+)(.*));
    ($dok,$dir,my %rets) = $m->setdokdir($dok,$dir);
    $url ||= $rets{url} || $m->ml_dok2absurl($dok, lang => $lang, lihs => $lihs);
    return $m->dpop($prog) unless $url;
    $url = $m->lokurl($url);
    $url .= $rest;
    $m->dpop1($prog,$url);
};


=head3 Function supdoktyp

superior document (in the hierarchy) and pretyp (type of subordination relation, 2 for group member, 3 for subdirectory).

exit with error if our dok has no superior node and is also not among the topdoks.

Presupposes set_topdoks.

  arg1: dok.  if nothing given use $m->pvar('dok') or get it from current directory

=cut

sub supdoktyp {
    my $prog = 'supdoktyp';my $m = shift;$m->dpuc($prog,@_);
    my $dok = shift || $m->pvar('dok') || $m->get_dok || $m->pstop(funnovar => v => 'dok');
    my $typ_min = shift || 3;
    $m->pstop('invalid typ_min value %t', t => $typ_min) unless $typ_min > 0;
    my @predoks = $m->get_predoks($dok);
    my $pretyp = 0;
    my $lastdok = $dok;
    my $predok = ''; 
  PRE: {
      last unless @predoks;
      $m->dpuc($lastdok, @predoks);
      $predok = pop @predoks;
    SUPDOK_OK: {
	$pretyp = $m->{dokprop}->{$lastdok}->{typ};
	$m->dpuc('supdok_ok', $pretyp, @predoks, $predok, $lastdok);
	$m->pstop('cant find pretyp of predok %p right after %P and before %l', p => $predok, P => \@predoks, l => $lastdok) unless $pretyp;
	do { $m->dpop;last } if $pretyp < $typ_min;
	@_ = ($predok, $pretyp);$m->dpop($prog,@_);return @_;
      };
      $m->dpop($lastdok, @predoks);
      $lastdok = $predok;
      redo;
    };
    $m->dpop($prog);return;
};

=head3 Function supdok

superior document (in the hierarchy).

=cut

sub supdok {
    my $prog = 'supdok';my $m = shift;$m->dpuc($prog, @_);
    my ($dok,$typ_min) = @_;
    local ($_) = $m->supdoktyp($dok,$typ_min);
    $m->dpop1($prog,$_);return $_;
};

=head3 Function supdir

Pathname of superior document node.

Optional first argument: current dok.

Optional second argument: minimal level of subordination, default is 3 = real directory subordination relation, 2 is a document group subordination relation, 1 a precedence relation among equal peers.

=cut

sub supdir {
    my $prog = 'supdir';my $m = shift;$m->dpuc($prog,@_);
    my $dok = shift || $m->pvar('dok') || $m->pstop(funnovar => v => 'dok');
    my $typ_min = shift || 3;
    my $supdok = $m->supdok($dok, $typ_min);
    return $m->dpop($prog) unless $supdok;
    my $dir = $m->dokdir_pur($supdok);
    $m->dpop1($prog, $dir);return $dir;
};

sub suppaf {
    my $m = shift;
    warn 'invoking supdir with deprecated name suppaf';
    return $m->supdir(@_);
};

=head3 Function supdirdoktyp

like supdir, but also return the corresponding dok (document symbol) and pretyp (subordination type by which its first subdocument is linked to it, usually 2 = group member or 3 = directory).

=cut

sub supdirdoktyp {
    my $prog = 'supdirdoktyp';my $m = shift;$m->dpuc($prog, @_);
    my $dok = shift || $m->pvar('dok') || $m->pstop(funnovar => v => 'dok');
    my $typ_min = shift || 3;
    my ($supdok, $suptyp) = $m->supdoktyp($dok, $typ_min);
    return $m->dpop($prog) unless $supdok;
    my $supdir = $m->dokdir_pur($supdok);
    @_ = ($supdir, $supdok, $suptyp);$m->dpop($prog,@_);return @_;
};


=head3 Function doksfile

takes dok, returns name of file where current level\'s hierarchy info should be stored, e.g. '_subdoks' or '_grpdoks', depending on where in the hierarchy we are.

=cut

sub doksfile {
    my ($m,$prog,$dok) = shift->ppuc('doksfile',@_);$dok ||= $m->pvar(dok => 1);
    my ($supdir, $supdok, $suptyp) = $m->supdirdoktyp($dok, 2);
    return $m->dpop($prog) unless $supdir;
    $m->pstop('no such parent directory %d', d => $supdir) unless -d $supdir;
    $m->pstop('parent directory %d must be of superordination type 2 or 3', d => $supdir) unless $suptyp and $suptyp > 1;
    my $fayl = $suptyp == 2 ? 'grpdoks' : 'subdoks';
    my $pfx = $m->get_srcfpfx(dir => $supdir);
    $fayl = $pfx . $fayl;
    $fayl = catfile $supdir, $fayl;
    $m->dpop1($prog,$fayl);
};

=head3 Function doksfiles

For use in MakefileCache.pm, perhaps outdated.
Was out of use for years until file:/phm/18/09/24/sig/_lng.phm_pub_sig180924.txt::doksfiles

=cut

sub doksfiles {
    my ($m,$prog,$dok) = shift->ppuc('doksfiles',@_);
    $dok ||= $m->get_dok;
    my $doksfile = $m->doksfile($dok);
    my $pfx = $m->pvar(srcfpfx => 1);
    local @_ = glob $pfx.'*doks';
    push @_, $doksfile unless grep { $_ eq $doksfile } @_;
    $m->dpop($prog,@_);
};

=head3 Function make_doksfile_line_rewriter

Create closure functions used by C<rewrite_doksfile>.

Each function is an operation designated by a symbol.  Currently we have 'mv' (move) and 'rm' (remove).

The function accepts a list of symbol_word_s that were found before the operation and returns a list of symbol_word_s that remain on that line after the operation (renaming or removing) is completed.

=cut

sub make_doksfile_line_rewriter {
    my ($m,$prog,$lihs,$kmd,$id0,$id1) = shift->opuc('make_doksfile_line_rewriter',3,@_);
    my $subr = undef;
  SUBR: {
      $m->pstop('no komand found') unless defined $kmd;      
      $m->pstop('lacking command argument 0 for %k', k => $kmd) unless defined $id0;
    MV: { # rename
	last if 'mv' ne $kmd;
	$m->pstop('lacking command argument 1 for %k and %a', k => $kmd, a => $id0) unless defined $id1;
	$subr = sub {
	    map { $_ eq $id0 ? $id1 : $_  } @_;
	};
	last SUBR;
      };
    RM: { # remove
	last if 'rm' ne $kmd;
	$subr = sub {
	    grep { $_ and $_ ne $id0 } @_;
	};
	last SUBR;
      };
    };
    $m->pstop('no function defined for doksfile rewriter command %k', k => $kmd) unless $subr;
    $m->dpop1($prog,$subr);
};

=head3 Function rewrite_doksfile

rewrite doksfile $1, applying procedure $2 with following arguments to each line found in the doksfile.

Supported procedures are

    mv $id0 $id2
    rm $id

That is the following invocations are supported:

    $m->rewrite_doksfile('akt/_grpdoks', 'mv', 'a2e_prog0710', 'a2e_adv0710');
    $m->rewrite_doksfile('_subdoks', 'rm', 'a2e_prog0710')

The first renames occurrences of a2e_prog0710 to a2e_adv0710, the second removes them.

The files consist of lines which either contain one or more blank separated document identifiers (dok) or comments starting with a hash mark (#).  Comment lines are left untouched.  Blank lines are removed.  When a line contains an identifier that matches the searched one (i.e. arg1 of 'rm' or 'mv'), the identifier is rewritten (i.e. replaced or deleted) and everything else stays unchanged.

=head4 BUGS

  FIXED: 2007-12-07: application the 'rm' had been leading to empty files.
  ? duplicated effort: similar code in get_doks, A2E::Subdoks::doksfile_add ?

=cut

sub rewrite_doksfile {
    my $prog = 'rewrite_doksfile';my $m = shift;$m->dpuc($prog,@_);
    my ($doksfile,$komand,@kmdargs) = @_;
    my $rewriter = $m->make_doksfile_line_rewriter($komand, @kmdargs);
    return $m->dpop($prog) unless $doksfile;
    $m->open_fayl($doksfile, 'doks', 'r');
    my %doks = ();
    my @lins = ();
  RELIN: while ($m->getlini('doks')) {
      # transform line $_ with $rewriter function and, if it did not become empty, push it onto @lins
      chomp $_;
      my ($blank, $lin) = m(\A(\s*)(\w.*)\b\s*\Z);
      # preserve leading blanks 
      next unless $lin;
      my @lin_doks0 = split m(\s+), $lin;
      @lin_doks0 = &$rewriter(@lin_doks0);
      my @lin_doks = (); # final version without duplicates
      foreach my $dok (@lin_doks0) {
	  next if $doks{$dok};
	  push @lin_doks, $dok;
	  $doks{$dok} = 1;
      };
      # omit the line if it became void
      next unless @lin_doks;
      # build the line with same leading blanks and push it onto @lins
      $lin = join ' ', @lin_doks;
      $lin = $blank . $lin;
      push @lins, $lin;
  };
    $m->kloz_fayl('doks');
    $m->open_fayl($doksfile, 'doks', 'w');
    $m->print_tu_fayl('doks', join("\n", @lins) . "\n"); 
    $m->kloz_fayl('doks');
    $m->svn_commit($doksfile);
    $m->dpop1($prog,1);return 1;
};

=head3 Function url2dir

Derive local directory from corresponding URL.  

Inversion of dir2url, core part of B<dokdir>

=cut

sub url2dir {
    my ($m,$prog,$lihs,$url,%opts) = shift->opuc('url2dir',[qw(url)],@_);
    my $dir = $url;
  LOKDIRP: {
      last unless $dir =~ m(\A\/);
      $dir = dirname $dir if -f $dir;
      $m->uwarn('dir %D does not exist here', D => $dir) unless -d $dir;
      $m->dpop1($prog,$dir);
      return $dir;
    }; 
    my ($prot, $dom, @dirs) = $m->url_parts($url);
    $m->pstop(grokurl => u => $url) unless $dom;
    my ($i, $j, $d, $basdir, @subdirs) = (0, 0, '', '');
    $dom =~ s(\Awww\.(.*)\Z)($1);
    unshift @dirs, $dom;
     foreach $i (0..$#dirs) {
	$j = $#dirs - $i;
	$d = join '/', @dirs[0..$j];
	$basdir = $m->{konfig}->urldirs->{$d} || '';
	# $m->dgot(j => $j, d => $d, basdir => $basdir); 
	next unless $basdir;
	@subdirs = @dirs[$j+1..$#dirs];
	last;
    };
    unless ($basdir) {
	$basdir = $m->{cache}->{primdir};
	@subdirs = @dirs[1..$#dirs];
    };
    $dir = catdir $basdir, @subdirs;
    $m->dpop1($prog,$dir);
};


=head3 $lurl = $m->rurl2lurl($rurl): Derive local url from remote url

needed by A2E::Cgidok.

=cut

sub rurl2lurl {
    my ($m,$prog,$lihs,$url,%opts) = shift->opuc('rurl2url',[qw(url)],@_);
    my ($prot, $dom, @dirs) = $m->url_parts($url);
    $m->pstop(grokurl => u => $url) if !$dom;
    my $vih = $m->{konfig}->domvihs->{$dom};
    $url = 'http://' . join '/', $vih, @dirs;
    $m->dpop1($prog,$url);
};

=head3 Function dokdir_pur

core part of B<dokdir>: return local directory corresponding to a dok.

=cut

sub dokdir_pur {
    my ($m,$prog,$lihs,$dok,$lang,%opts) = shift->opuc('dokdir_pur',[[qw(nom)],[qw(lang_let)]],@_);
    my $dir = $m->ml_dok2absdir($dok,lang => $lang, %opts);
    return $m->dpop($prog) unless $dir;
    $m->dpop1($prog,$dir);
};

=head3 $dir = $m->dokdir($dok,$lang?,%opts): pathname of dok on localhost

$dok :: dok identifier e.g. something like oas_akt0708 or even same with an appended rest like oas_akt0708/tra
$dir :: pathname of corresponding directory on the local host
 
Suitable as an argument to chdir.
An option lang argument should decide whether and for which language we want the dir/url localised.
If a global $m->{lang} is set then that has the same effect.
Localisation of dir/url names is done by using the alternative directory names stored in a2edb column traprop.tranom.

=cut

sub dokdir {
    my ($m,$prog,$lihs,$dok,$lang) = shift->opuc('dokdir',[qw(nom_get lang_let)],@_);
    my $rest = '';
    ($dok, $rest) = $dok =~ m(\A(\w+)(.*)\Z);
    $m->set_alidoks(lihs => $lihs);
    $dok = $m->alidok($dok, lihs => $lihs);
    my $dir = $m->dokdir_pur($dok, lang => $lang);
    $dir .= $rest;
    $m->dpop1($prog,$dir);
};

sub dok2dir8url {
    my ($m,$prog,$dok) = shift->ppuc('dok2dir8url',@_);
    return $m->dpop($prog) if !$dok;
    my $dir = $m->{dokprop}->{$dok}->{dir};
    return $m->dpop1($prog,$dir) if $dir;
    my $url = $m->dok2absurl($dok);
    $dir = $m->lokurl($url);
    $m->dpop($prog,$dir,$url);
};
sub dokdir_robust {
    my ($m,$prog,$dok) = shift->ppuc('dokdir_robust',@_);
    my ($dir,$url) = $m->dok2dir8url($dok);
    $m->dpop1($prog,$dir);
};

=head3 Function dir2dir

take directory, typically the one returned by Cwd::getcwd, and convert this to what the name should ideally be when used in the local file system with shell commands like `cd', e.g.

    /homdisk/svn/sig_adv/perl/A2E --> /sig/perl/A2E

The second form is built on symlinks.

Note: dir2dir returns the symlink-directory in which we really are, not the one we should be in based on language based symlink rule.

This requires configuration, see configurable section above.

=head4 BUGS

=over

=item FIXED: /ffiinnc/sig/08/05 --> /sig/ffiinnc/08/05

This should not happen.  It leads to wrong urls generated by dir2url.

SOLUTION: in dokfs.konf: svnbas2dir sig_ffiinnc = /ffiinnc/sig

=item FIXED 2008-09-15: /eupat/papri/europarl0309/amends05 --> /amends/05

Wrong URLs generated when directories end in dates.  SOLUTION: closure $matchdir, removed old function svnbas2dir

=back

=cut

sub dir2dir ($;$) {
    my ($m,$prog,$dir) = shift->ppuc('dir2dir',@_);$dir ||= $m->get_cwd;
    if ($dir =~ m(\A(.*)\/+\Z)) { $dir = $1 };
  TRIM_ROOT: {
      my $root = $m->{svn_repos}->{root};
    KONFIG: {
	last if $root;
	my $svn_root = $m->{konfig}->svn_root;
	($root) = $dir =~ m(\A($svn_root)\b);
      NOROOT: {
	  last if $root;
	  $m->decho('directory %d not matched by svn_root regex %r', d => $dir, r => $svn_root);
	  last TRIM_ROOT;
	};
      };
      $m->pstop('root part of svn repository tree unknown') unless $root; 
      my $rest = '';
      ($root, $rest) = $dir =~ m(\A($root)\b(.*)\Z);
      return $m->dpop1($prog,$dir) unless $rest;
      $dir = $rest;
    };
  TRY: {
      local $_ = $dir;
    PRIM: {
	my $primdir = $m->pvar('primdir');
	$primdir = catdir split '/', $primdir; # configure with unix conventions, apply OS conventions
	last unless -d $primdir;
	my ($rest) = m(\A$primdir\b(.*)\Z);
	last unless $rest;
	$dir = $rest;
	last TRY;
      };
      my @dirs = splitdir $dir;
      shift @dirs;
      $_ = shift @dirs;
      my $matchdir = sub {
	  my @matches = @_;
	  return unless @matches;
	  my $bas = shift @matches;
	  my $basdir = $m->{konfig}->svnbas2dir->{$bas};
	  return unless $basdir;
	  my $dir = catdir $basdir, @matches, @dirs;
	  return $dir;
      };
      # sig_oas1312, sig_oas13, sig_oas
      my @svnbas_regexps = $m->{konfig}->svnbas_regexps;
      foreach my $re (@svnbas_regexps, '(\w+)') {
	  $dir = &$matchdir(m(\A$re\Z));
	  last TRY if $dir;
      };
      $dir = $m->svnbasdirs2dir($_, @dirs);
    };
    $m->dpop1($prog,$dir);
};

=head3 Function dir2fol

leaf of directory

	args := dir
	dir => /eupat/stidi/epla
	rets := fol    
	fol => epla

Very trivial provisional means of solving a problem in A2E::Dokdata without loading &File::Spec::Functions::splitdir there, a more robust way would be a function dok2fol that looks up dokprop.doknom

=cut

sub dir2fol {
    my ($m,$prog,$dir) = shift->ppuc('dir2fol',@_);
    my @dirs = splitdir $dir;
    my $fol = pop @dirs;
    if (-l $fol) { $fol = readlink $fol };
    $m->dpop1($prog,$fol);
}

=head3 Function doklfols 

Localising links to the leaf of the current document, e.g. 'papers', 'papiers' and 'papiere' for document 'swpatpapri' with leaf 'papri'.

=cut

sub doklfols {
    my $m = shift;
    $m->dpuc('doklfols', @_);
    my $dok = shift;
    my @reks = $m->get_records('traprop', { dok => $dok }, 'tranom');
    my @lfols = map { $_->[0] } @reks;
    $m->dpop('doklfols', @lfols);
    return @lfols;
};

=head3 Function dir2url

Derive URL from directory argument or current working directory.

Be fast, ignore _url files and database.

=cut

sub dir2url ($;$) {
    my ($m,$prog,$dir) = shift->ppuc('dir2url',@_);$dir ||= $m->dir2dir(getcwd());
    my %dirurls = %{$m->{konfig}->dirurls};
    my @dirs = splitdir $dir;
    my ($i, $j, $d, $dom, @subdirs) = ();
    foreach $i (1..$#dirs) {
	$j = scalar @dirs - $i;
	$d = catdir @dirs[0..$j];
	next unless $dirurls{$d};
	$dom = $dirurls{$d};
	@subdirs = @dirs[$j+1..$#dirs];
	last;
    };
    unless ($dom) {
	$dom = $m->{konfig}->primurl;
	shift @dirs;
	@subdirs =  @dirs;
    };
    my $url = join '/', $dom, @subdirs;
    $m->dpop1($prog,$url);
};

=head3 Function get_dok

find the document identifier (dok) of the current directory.

Use several methods, each of which are separately defined as a plugin: 
 - search in a file _dok
 - search in the document names _(lng|dok).(\w+).txt
 - search in the Makefile.

=head4 plugin constructor make_meta2dok

invoked by configuration statement

    get_dok_plugins = meta

=cut

sub make_pvar2dok {
    my ($m,$lihs) = @_;
    return sub {
	$m->pvar(dok => 0);
    };
};
sub make_meta2dok {
    my $m = shift;
    return sub {
	my $pfx = $m->pvar(srcfpfx => 1);
	my $fi = $pfx.'dok';
	return if !-r $fi;
	$m->fayl_get_str($fi,1);
    };
};

=head4 plugin constructor make_makefile2dok

invoked by configuration statement

    get_dok_plugins = make

=cut
 
sub make_makefile2dok {
    my $m = shift;
    return sub {
	my $fi = 'Makefile';
	return if !-r $fi;
	$m->open_fayl($fi, 'i', 'r');
	local $_;
	my ($dok, @matches) = ();
	while ($m->getlini('i')) {
	    chomp $_;
	    @matches = m(\ADOK\s*\:\=\s*(.*)\s*\Z);
	    next unless @matches;
	    $dok = $matches[0];
	    last;
	};
	$m->kloz_fayl('i');
	$dok;
    };
};

=head4 plugin constructor make_dir2dok

invoked by configuration statement

    get_dok_plugins = dir

implemented as a wrapper around function dirdok.

=cut

sub make_dir2dok {
    my $m = shift;
    return sub {
	$m->dirdok();
    };
};

=head4 plugin constructor make_konfigdok

invoked by configuration statement

    get_dok_plugins = konfig

implemented as a wrapper around function dirdok.

=cut

sub make_konfig2dok {
    my $m = shift;
    return sub {
	$m->{konfig}->dok;
    };
};

=head4 Function get_dok

get current document using plugged-in methods according to their sequence of priority

=cut

sub get_dok {
    my ($m,$prog,$lihs) = shift->lpuc('get_dok',@_);
    my $dok = $lihs->{vars}->{__dok__} || $lihs->{vars}->{dok};
    my $dir = $m->dir2dir($lihs->{vars}->{__dir__}); 
    if ($dok) {
	$m->{dokprop}->{$dok}->{dir} ||= $dir;
	return $m->dpop1($prog,$dok);
    };
    my @plugins = @{$m->{konfig}->get_dok_plugins};
  PLUGIN: {
      last unless @plugins;
      my $plugin = shift @plugins;
      my $meth = $m->{get_dok_plugins}->{$plugin};
      $m->pstop('plugin %P undefined', P => $plugin) if !$meth;
      $dok = &$meth;
      if ($dok) {
	  $m->{dokprop}->{$dok}->{dir} ||= $dir;
      } else {
	  redo;
      };
      $m->setpvar(dok => $dok, lihs => $lihs);
    };
    $m->pwarn(funnovar => v => 'dok') if !$dok;
    $m->dpop1($prog,$dok);
};
sub get_tmpl {
    my ($m,$prog,$lihs) = shift->lpuc('get_tmpl',@_);
    my $tmpl = $lihs->{vars}->{__tmpl__} || $lihs->{vars}->{__tmpl} || $lihs->{vars}->{tmpl} || $m->pvar(tmpl => 1);
    $m->pwarn(funnovar => v => 'tmpl') if !$tmpl;
    $m->dpop1($prog,$tmpl);
};
sub get_dir {
    my ($m,$prog,$lihs,$dok) = shift->lpuc('get_dir',@_);
    my $dir = $dok ? $m->dokdir_robust($dok) : $m->dir2dir($lihs->{vars}->{__dir__} || $m->dir2dir);
    $m->pwarn(funnovar => v => 'dir') if !$dir;
    $m->dpop1($prog,$dir);
}
sub get_lang {
    my ($m,$prog,$lihs) = shift->lpuc('get_lang',@_);
    my $lang = $m->{konfig}->lang || $m->pvar(lang => 1) || $lihs->{lsts}->{langs}->[0];
    $m->pwarn(funnovar => v => 'lang') if !$lang;
    $m->dpop1($prog,$lang);
};

=head3 Function set_dok

invoke get_dok and write the result into pvar 'dok'.
    
=cut

sub set_dok { 
    my ($m,$prog,$lihs) = shift->lpuc('set_dok',@_);
    my $dok = $m->get_dok($lihs);
    $m->setpvar(dok => $dok, lihs => $lihs); # get_dok currently does this already but that could change
    $m->dpop($prog,$dok);
};

=head3 $url = $m->fayl_set_url($dok,$lang): find url in I<url_fayl> and write derived info to database

This may be obsolete

=cut

sub fayl_set_url {
    my ($m,$prog,$lihs,$dok,$lang) = shift->vlpuc('fayl_set_url',[qw(dok lang_let)],@_);
    $m->pwarn('setting the url based on a file is an obsolete method');
    my $fi = '';
    my $url = '';
  TRY: {
    LANG: {
	last unless $lang;
	$fi = $m->url_fayl($lang);
	last unless -r $fi;
	$url = $m->fayl_get_str($fi,1);
	last TRY if $url;
    };
    DOK: {
	$fi = $m->url_fayl;
	last unless -r $fi;
	$url = $m->fayl_get_str($fi,1);
	last TRY if $url;
    };
    NULL: {
	$fi = $m->pvar(srcfpfx => 1) . 'url';
	last unless -r $fi;
	$url = $m->fayl_get_str($fi,1);
	last TRY if $url;
    };
  };
    chomp $url;
    return $m->dpop($prog) if !$url;
    $m->setpvar(url => $url);
    $m->set_urldata;
    $m->dpop1($prog,$url);
};

=head3 Function dirlangs

Return languages of document, based on what is found in the languages file (normally '@langs') of the directory given in arg1 which defaults to the current directory.
Analogous to dirdok.

Ideally the languages should be all in the 1st line and separated by
whitespace, but this routine is a bit more tolerant.  It also accepts comment lines
and spread of languages across more lines.  Moreover it eliminates doubles.

=cut

sub langsfayl {
    my $m = shift;
    my %repl = @_;
    my $pfx = $m->pvar(srcfpfx => 1);
    $repl{p} ||= $pfx;
    return $m->hsprintf($m->{konfig}->langsfnom, %repl);
};
sub fnom2regex {
    my $m = shift;
    local $_ = shift;
    s(\.)(\\.)g;
    return $_;
}
sub dirlangs {
    my $m = shift;
    $m->dpuc('dirlangs', @_);
    my $dir = shift || '.';
    my $fi = catfile $dir, $m->langsfayl;
    do { $m->dpop;return } unless -r $fi;
    $m->open_fayl($fi, 'langs', 'r');
    my $n = 0;
    $n = 0;
    my ($l, @ll, @langs, %lh);
    while ($m->getlini('langs')) {
	chomp;
	$n++;
	$m->dpuc($n, $_);
	do { $m->dpop;next } unless m(\A\w);;
	@ll = split /\s+/, $_;
	foreach $l (@ll) {
	    do { $m->uwarn('language name %l appearing twice in file %f', l => $l, f => $fi);next } if $lh{$l};
	    do { $m->uwarn('forbidden language name %l in file %f', l => $l, f => $fi);next } unless $l =~ m(\A[a-z][a-z]\w{0,4}\Z);
	    push @langs, $l;$lh{$l} = 1;
	};
    };
    $m->kloz_fayl('langs');
    $m->dpop('dirlangs', @langs);return @langs;
};

=head3 Function get_langs

find languages of the current directory or the directory belonging to the document identifier of argument 1.

=cut

sub get_langs {
    my ($m,$prog,$lihs,$dok,$dir,%opts) = shift->opuc('get_langs',[[],[qw(dok_let dir_let)]],@_);
    my @langs = ();
  NODOK: {
      last if $dok;
    LANGS: {
	@langs = $lihs->getlst('langs');
	last if @langs;
	@langs = $m->plst('langs');
      };
      return $m->dpop($prog,@langs) if @langs;
    };
  MONO: { # limit scope of languages where the user specified this and we are working only locally
      last if $dok;
      my $lang = $m->{konfig}->lang;
      last unless $lang;
      return $lang;
    };
    if ($dok) {
      DIR: {
	  last if $dir;
	  $dir = $m->{dokprop}->{$dok}->{dir};
	  last if $dir;
	  $dir = $m->db_dokdir($dok);
	  last unless $dir;
	  $m->{dokprop}->{$dok}->{dir} = $dir;
	};
    } else {
	$dok = $m->get_dok;
	$dir = $lihs->{__dir__} || $m->dir2dir;
	$m->{dokprop}->{$dok}->{dir} ||= $dir;
    };
    return $m->dpop($prog) if !$dok;
    $m->ustop(doknedir => d => $dir, k => $dok) unless $dir;
    ($dir,my $olddir) = $m->chwd($dir) unless -r catfile $dir, $m->hsprintf('%plng.%d.txt', d => $dok);
    @langs = $m->dirlangs($dir);
  LANGS: {
      last if @langs;
      $m->uwarn(dirnolangs => d => $dir) unless @langs;
      my @faylz = glob $m->lng_fayl(l => '??', d => '*');
      my $re = $m->hsprintf($m->fnom2regex($m->{konfig}->lexfnom), l => '(\w{2})',d => '\w+');
      @langs = map { my ($lang) = m(\A$re\Z);$lang } @faylz;
    };
    $m->uwarn(DirNoLangs => d => $dir) unless @langs;
    $m->chwd($olddir) if $olddir;
    $m->dpop($prog,@langs);
};

=head3 Function valid_subdir

take subdir name and return same if it contains a valid subdocument node, otherwise return nil.
not a validator function like valid_tmpl.

=cut

sub valid_subdir {
    my $m = shift;
    $m->dpuc('valid_subdir', @_);
    my $dir = shift;
    my $fi = '';
  NO_DIR: {
      $m->dpuc('no_dir', $dir);
      do { $m->dpop;last } if -d $dir;
      $m->dpop('valid_subdir');return;
    };
  IS_LINK: {
      $m->dpuc('is_link', $dir);
      do { $m->dpop;last } unless -l $dir;
      $m->dpop('valid_subdir');return;
    };
  NO_MAKEFILE: {
      $m->dpuc('no_makefile');
      $fi = catfile $dir, 'Makefile';
      do { $m->dpop1('no_makefile', $fi);last } if -s $fi;
      $m->dpop('valid_subdir');return;
    };
    my $pfx = $m->get_srcfpfx(dir => $dir);
  NO_PFX: {
      $m->dpuc('no_pfx');
      do { $m->dpop1('no_pfx', $pfx);last } if $pfx;
      $m->dpop('valid_subdir');return;
    };
  NO_DOK: {
      $m->dpuc('no_dok');
      my @faylz = glob catfile $dir, $m->hsprintf($m->{konfig}->mulfnom, p => $pfx, dok => '*');
      do { $m->dpop('no_dok', @faylz);last } if @faylz;
      $m->dpop('valid_subdir');return;
    };
    $m->dpop1('valid_subdir', $dir);
    return $dir;
};

=head3 Function subdirs

Return the list of subdirectories which may need to be checked/parsed/compiled before the current directory is committed to the subersion repository.

These subdirectories must be in the same subversion repository.

Consequently they can not be symlinks.

=cut

sub subdirs {
    my $m = shift;
    $m->dpuc('subdirs');
    my $sep = ' ' || shift;
    my $fi = '';
    my @matches = ();
    my @subdirs = ();
  TRY: {
      $m->dpuc('try');
    FILE: {
	$fi = $m->hsprintf('%psubdirs');
	$m->dpuc('file', $fi);
	do { $m->dpop;last } unless -r $fi;
	$m->open_fayl($fi, 'i', 'r');
	while ($m->getlini('i')) {
	    chomp;
	    @matches = m(\A\s*(\w+)\s*\Z);
	    next unless @matches;
	    push @subdirs, $matches[0];
	};
	$m->kloz_fayl('i');
	do { $m->dpop('try');last TRY } if @subdirs;
	$m->dpop;
    };
    GLOB: {
	$m->dpuc('glob');
	@subdirs = glob '*/';
	@subdirs = grep {$_} map { m(\A(.*)\/\Z) && $m->valid_subdir($1) } @subdirs;
	do { $m->dpop('try');last TRY } if @subdirs;
	$m->dpop;
      };
      $m->dpop('try');
    };
    $m->dpop('subdirs', @subdirs);
    return @subdirs;
};

=head3 Function set_subdirs

Set the object property 'subdirs' to the list returned by C<subdirs> and return a string representation of that list where the subdirs are separated by whitespaces or, alternatively, by a separator specified in arg 1. 

Some programs such as dokfs_subdirs may depend on the returned string, but in the long run this should be in a separate function, not set_subdirs.  Normally the C<subdirs> function should be used, and C<set_subdirs> should onyl be used as a shorthand for setting the subdirs property.

=cut

sub set_subdirs {
    my $m = shift;
    $m->dpuc('set_subdirs', @_);
    my $sep = shift || ' '; 
    @{$m->{subdirs}} = $m->subdirs;
    my $res = join $sep, @{$m->{subdirs}};
    $m->dpop1('set_subdirs', $res);
    return $res;
};

=head3 Function get_doks

find the documents of the current document hierarchy level, as typically stored in a _subdoks or _grpdoks file and in corresponding database records.

=head4 Subroutine fayl_postdoks

Return documents of a given file like /sig/_subdoks.
Original purpose of listing everything menu documents of the current level as reflected in the function name fayl_postdoks may be obsolete or not reliably attainable.

=cut

sub fayl_postdoks {
    my ($m,$prog,$fi) = shift->ppuc('fayl_postdoks',@_);
    return $m->Wpop0($prog, d => nofylr => f => $fi) unless -r $fi;
    $m->open_fayl($fi, 'doks', 'r');
    my @doks = ();
    my $dok = ''; 
  GETLINI: {
      my $blok = 'getlini';
      local $_ = $m->getlini('doks');
      last unless $_;
      chomp;
      ($dok) = m(\A(\w[\w\s]*\w)\W*\Z);
      redo unless $dok;
      push @doks, split /\s+/, $dok;
      redo;
    };
    $m->kloz_fayl('doks');
    $m->dpop($prog, @doks);
};

=head4 Subroutine dirsubdoks

Reconstruct documents of current hierarchy level from what is seen in subdirectories and return them

TODO extend to deal with _grpdoks subordination of pretyp 2 as well, use /adv/prg/bin/subdirs.pl:subdirs as a model and possibly as a common basis

=cut 

sub dirsubdoks {
    my ($m,$prog,$dir) = shift->ppuc('dirsubdoks',@_);
    $dir ||= $m->dir2dir;
    my $dok2dir = $m->sup_dok2dir($dir);
    my @doks = keys %$dok2dir;
    $m->dpop($prog,@doks);
};

=head Function get_doks

Find my subdocuments of a $dokstyp ('subdoks' or 'grpdoks') by reading available files or database entries

=cut

sub get_doks {
    my ($m,$prog,$dokstyp,%opts) = shift->ppuc('get_doks',@_);
    my $FaylP = !$opts{NFaylP} || 0; # try read from file
    my $DabaP = $opts{DabaP} || 0; # try read from database
    my $DirsP = $opts{DirsP} || 0; # try read from dirs
    my $lihs = $m->get_lihs($opts{lihs});
    my $pfx = $m->pvar(srcfpfx => 1);
    my $FDoks = $opts{FDoks};
    $FDoks ||= $pfx.$dokstyp if $dokstyp;
    my $dir = $opts{dir} || $m->pvar('supdir');
    $FDoks = $m->absfayl($FDoks,$dir);
    my @doks = ();
  FAYL: {
      last unless $FaylP;
      last unless $FDoks;
      last unless -r $FDoks;
      @doks = $m->fayl_postdoks($FDoks);
      last unless @doks;
      return $m->dpop($prog, @doks);
    };
  DABA: {
      last unless $DabaP;
      @doks = $m->daba_postdoks;
      last unless @doks;
      return $m->dpop($prog,@doks);
    };
  DIRS: {
      last unless $DirsP;
      last unless $dokstyp eq 'subdoks';
      @doks = $m->dirsubdoks($dir);
      last unless @doks;
      return $m->dpop($prog, @doks);
    }
    $m->dpop($prog);
};

=head3 Function set_doks

store the findings of get_doks

=cut

sub set_doks {
    my ($m,$prog,$varname,%opts) = shift->ppuc('set_doks',@_);
    $varname ||= 'subdoks'; # 'subdoks' or 'grpdoks'
    my @doks = $m->get_doks($varname, %opts);
    $m->setplst($varname => \@doks);
    $m->dpop($prog,@doks);
};

=head3 Function rewrite_subdoks

Find all subdoks of the current node and append them to the right _subdoks file as far as they are not already found there or in an inferior _grpdoks file.

=cut

sub rewrite_subdoks {
    my $prog = 'rewrite_subdoks';my $m = shift;$m->dpuc($prog,@_);
    my @file_subdoks = $m->get_doks('subdoks');
    my $cwd = getcwd;
    my $pwd = $m->dir2dir($cwd);
    $m->chwd($pwd, msg => "cant even change to equivalent $pwd of $cwd");
    my @matches = ();
    my $subdir = '';
    local $_;for (glob '*/_grpdoks') {
	$m->dpuc($_);
	@matches = m(\A(\w[^/]*\/));
	$m->pstop("simple subdir path regexp not matched") unless @matches;
	$subdir = $matches[0];
	$m->chwd($subdir, msg => "cant change to subdir $subdir");
	push @file_subdoks, $m->get_doks('grpdoks');
	$m->chwd($pwd, msg => "cant chdir back to $pwd");
	$m->dpop;
    };
    my @dir_subdoks = $m->get_doks('subdoks', DirsP => 1, NFaylP => 1);
  NO_DIR_SUBDOKS: {
      $m->dpuc('no_dir_subdoks', @dir_subdoks); 
      do { $m->dpop;last } if @dir_subdoks;
      $m->dpop($prog);
      return;
    };
    my $dok = $m->set_dok;
  NO_DOK: {
      $m->dpuc('no_dok', $dok);
      do { $m->dpop;last } if $dok;
      $m->dpop($prog);
      return;
    };
    my ($pretyp) = $m->get_record('dokprop', { predok=>$dok }, 'pretyp');
  GRPDOKS: {
      $m->dpuc('grpdoks', $pretyp);
      do { $m->dpop;last } unless $pretyp == 2;
      $m->dpop($prog);return;
    };
    my $pfx = $m->pvar(srcfpfx => 1);
    my $f = $pfx.'subdoks';
    my $new_p = !-e $f;
    my $mode = $new_p ? 'w' : 'a';
    # $m->open_fayl($f, 'x', $mode);
    my %done_subdoks = ();
    foreach my $nom (@file_subdoks) { $done_subdoks{$nom} = 1 };
    foreach my $dok (@dir_subdoks) {
	next if $done_subdoks{$dok};
	$m->pwarn('In datei %f wollte %P das Dokument %d im Modus %m einfügen, aber wir lassen das nicht zu.', f => $f, m => $mode, d => $dok);
	# $m->print_tu_fayl('x', "\n".$dok);
	$done_subdoks{$dok} = 1;
    };
    # $m->kloz_fayl('x');
    # $m->svn_add($f) if $new_p;
    $m->dpop1($prog, 1);
    return 1;
};

=head3 Functions doksrc, unidoksrc, muldoksrc

Take document identifier (dok), return full path of the editable source file, either multilingual or in specified language or in document's primary language.

=head4 Function unidoksrc

=cut

sub unidoksrc { 
    my ($m,$prog,$lihs,$lang,$dok,$dir) = shift->opuc('unidoksrc',[qw(get_lang nom_get dir_get)],@_);
    my $pfx = $m->pvar(srcfpfx => 1);
    my $fol = $m->hsprintf($m->{konfig}->unifnom, p => $pfx, d => $dok, l => $lang);
    my $paf = catfile $dir, $fol;
  NOT_FOUND: { 
      last if -r $paf;
      return;
    };
    $m->dpop1('unidoksrc', $paf);
};

=head4 Function muldoksrc

=cut

sub muldoksrc {
    my ($m,$prog,$lihs,$dok,$dir) = shift->opuc('muldoksrc',[qw(get_dok get_dir)],@_);
    my $pfx = $m->pvar(srcfpfx => 1);
    my $fol = $m->hsprintf($m->{konfig}->mulfnom, p => $pfx, d => $dok);
    my $nom = catfile $dir, $fol;
    $m->dpop1($prog,$nom);
};

=head4 Function doksrc

=cut

sub doksrc {
    my ($m,$prog,$lihs,$dok,$lang,%opts) = shift->opuc('doksrc',[qw(nom_get lang_let)],@_);
    my $rest = '';
    ($dok, $rest) = $dok =~ m(\A(\w+)(.*)\Z);
    $dok = $m->alidok($dok, lihs => $lihs);
    my $dir = $m->dokdir_pur($dok);
    my $src = '';
  REST: {
      last if 0 == length $rest;
      $src = $dir . $rest;
      return $m->dpop1($prog,$src);
    };
    $src = $m->muldoksrc($dok, $dir);
    my $src0 = $src;
    return $m->dpop1($prog,$src) if -r $src or $opts{typ} eq 'muldok';
    $src = $m->unidoksrc($lang, $dok, $dir);
    return $m->dpop1($prog,$src) if -r $src;
    $src = $src0;
    $m->vecho('no readable file found, falling back to %f', f => $src);
    $m->dpop1($prog,$src);
};

=head2 Document Hierarchy

This is a basis not only for generating menus but also for determining which templates, css files etc to use in generating the object files.

=head3 Function get_predoks

    args := dok, (nom=> val)*
    rets := predoks*

list the whole chain of superordinated dokuments from the topdok level down to the given dok, using memory if possible, file system or database otherwise.

Option topinddok defaults to 'topdok' but could also be set to 'inddok'; in the latter case the hierarchy ladder is climbed up to the web domain root directory (where a sitemap_index is to be created) rather than to the microsite (topdok) root (where a sitemap is to be created).
Option NFaylP means dont read from filesystem, DabaP means read from database.

Once predoks were obtained properly they are stored in m->{${dok}_${topinddok}_predoks}.

=cut
sub topinddok_fayl {
    my ($m,$prog,$lihs,$dok,$dir,$topinddok) = shift->lpuc('topinddok_fayl',@_);
    my $pfx = $m->pvar(srcfpfx => 1, $lihs);
    my $fayl = catfile $dir, join '.', $pfx.$topinddok, $dok, 'txt';
    $m->dpop1($prog,$fayl);
};	  

sub setdokdir {
    my ($m,$prog,$lihs,$dok,$dir,%opts) = shift->opuc('setdokdir',[qw(nom_let dir_let)],@_);
    if ($dok) {
	$dok = $m->alidok($dok);
      DOK2DIR: {
	  $dir = $m->{dokprop}->{$dok}->{dir};
	  last if $dir;
	  $m->vecho('must look up dir for dok %d', d => $dok);
	  ($dir,$opts{url}) = $m->dok2dir8url($dok);
	  last if $dir;
	  return $m->Wpop0($prog, p => doknodir => d => $dok);
	};
    } else {
      DIR2DIR: {
	  last if $dir;
	  $dir = $m->get_dir($lihs);
	  last if $dir;
	  $m->pstop('found no dir');
	};
      DIR2DOK: { 
	  $dok = $m->dir2dok($dir);
	  last if $dok;
	  $m->pstop('found no dok in dir %d', d => $dir);
	};
    };
    $m->{dokprop}->{$dok}->{dir} = $dir;
    $m->dpop($prog,$dok,$dir,%opts);
};    
sub get_predoks {
    # select up to the upper branch but not higher
    my ($m,$prog,$lihs,$dok,%opts) = shift->opuc('get_predoks',[qw(dok)],@_);
    my $dir = $opts{dir};
    ($dok,$dir) = $m->setdokdir($dok,$dir);
    $m->pstop(funnovar => v => 'dok') unless $dok;
    my $topinddok = $opts{topinddok} || 'topdok';
    my $topinddoks = $topinddok.'s'; # topdoks
    my $topinddokp = $topinddok.'p'; # topdokp
    $m->set_topdoks($lihs);
    $m->set_alidoks;
    $dok = $m->alidok($dok);
    my @predoks = ();
    my $predok = $dok;
  REMONT: {
      my $in_topdoks = $m->{$topinddoks}->{$predok};
      last if $in_topdoks;
    DOKPROP: {
	last unless $predok;
	unshift @predoks, $predok if $m->noninfinilup($predok, @predoks);
	my $prop = $m->{dokprop}->{$predok};
	last unless $prop;
	$predok = $prop->{dok};
      };
    TOPINDDOKP: {
	last unless @predoks;
	my $dok = $predoks[0];
	my $pidp = $m->{dokprop}->{$dok}->{$topinddokp};
	my $tidp = $m->{$topinddoks}->{$dok};
	last unless $pidp or $tidp;
      FYL: {
	  my $dir = $m->{dokprop}->{$dok}->{dir};
	  $m->pstop('%P arrived at topdok %d whose dir is unknown', d => $dok) unless $dir;
	  touch $m->topinddok_fayl($lihs,$dok,$dir,$topinddok);
	};
	$m->{dokprop}->{$dok}->{$topinddokp} = 1;
	$m->{$topinddoks}->{$dok} = 1;
	last REMONT;
      };
    DOKS: {
	my @doks = @predoks;
	$dok = shift @doks;
	@predoks = do { if ($opts{DabaP}) { $m->daba_predoks($dok) } elsif (!$opts{NFaylP}) { $opts{topinddok} = $topinddok;$opts{dir} = $dir;$m->fayl_predoks($dok, %opts) } };
	push @predoks, @doks;
      }
    };
    $dok = pop @predoks;
    $m->dpop($prog,@predoks);
};

=head3 Function set_topdok

Find upmost node of site, set predoks hierarchy on the way.

Stop unless information about topdoks ($m->{topdoks}) has been collected, e.g. by set_topdoks.

=cut

sub set_topdok {
    my ($m,$prog,$lihs,$dok,$dir,%opts) = shift->opuc('set_topdok',[[qw(dok)],[qw(dir_let)]],@_);
    my $topdok = $m->pvar('topdok');
    ($dok,$dir) = $m->setdokdir($dok,$dir);
    $m->pstop(funnovar => f => $prog, v => 'dok') unless $dok;
    $m->pstop('trying to set topdok without having set topdoks') unless $m->{topdoks};
  ARIVIT: {
      my $ok = $m->{topdoks}->{$dok};
      last unless $ok;
      $m->setpvar(topdok => $dok);
      $lihs->putstr(topdok => $dok, %opts);
      return $m->dpop1($prog,$dok);
    };
    my @predoks = $m->get_predoks($dok, dir => $dir);
  NO_PREDOKS: {
      last if @predoks;
      my $pwd = $m->pvar(pwd => 1);
      $m->put('topdok', { topdok => $dok }, lastmod => 'today()') if $m->topinddokp($dok, $pwd, topinddok => 'topdok');
      $m->ustop(notopnopre => d => $dok);
    };
    $topdok = $predoks[0];
    $m->ustop('invalid topdok %D', D => $topdok) unless $m->{topdoks}->{$topdok};
    $m->setpvar(topdok => $topdok);
    $lihs->putstr(topdok => $topdok, %opts);
    $m->dpop1($prog,$topdok);
};

=head3 Function set_topdir

find and store the topdir, i.e. the directory corresponding to the topdok.

This is info needed by the Makefiles that generate object files using templates and CSS files that are stored in this directory.

=cut

sub set_topdir {
    my ($m,$prog,$lihs,$dok) = shift->opuc('set_topdir',[qw(nom_get)],@_);
    my $topdir = $m->pvar(topdir => 0, $lihs);
    return $m->dpop1($prog,$topdir) if $topdir;    
    $m->set_alidoks(lihs => $lihs);
    my $topdok = $m->set_topdok($dok,lihs => $lihs);
    $m->pstop(notopdok => d => $dok) unless $topdok;
    $topdir = $m->dokdir($topdok);
    $m->setpvar(topdir => $topdir, lihs => $lihs);
    $lihs->putstr(topdir => $topdir);
    my $topurl = $m->dok2absurl($topdok);
    $m->setpvar(topurl => $topurl, lihs => $lihs);
    $m->dpop1($prog,$topdir);
};

=head3 Function topdir_svn_cleanup

perform cleanup at topdir level, thus avoiding locking bugs that tend to occur when it is done at a lower level.

=cut

sub topdir_svn_cleanup {
    my ($m,$prog,$lihs) = shift->lpuc('topdir_svn_cleanup',@_);
    my $topdir = $m->pvar(topdir => 0, $lihs);
    my ($cwd,$lwd) = $m->chwd($topdir) if $topdir;
    $m->svn_cleanup;
    $m->chwd($lwd, msg => "cant even chdir back to %d", d => $lwd) if $topdir;
    $m->dpop1($prog,1);
};

=head3 Function set_topcss

Set the filepath of the CSS file as referenced in the HTML object version of the dok.

Return non-null if successful;

=cut

sub set_topcss {
    my ($m,$prog,$lihs,$dok)= shift->opuc('set_topcss',[qw(nom_get)],@_);
    my $topdok = $m->set_topdok($dok);
    my $topdir = $m->set_topdir($dok);
    my $basename = join '.', $topdok, 'css';
    my $topcss = catfile $topdir, $basename;
    $m->setpvar(topcss => $topcss, lihs => $lihs);
    $m->dpop1($prog,$topcss);
};

=head3 Function supsubfoldirs

Find something like glob "$sup/*/$fol" where $sup could be '/sig/tmp/17/05' and $fol '_grpdir' and the result is what is matched by '*'.

=cut

sub localdirlink {
    local $_ = shift;
    return unless -l $_;
    $_ = readlink $_;
    return unless m(\A\w+\Z);
    return $_;
}
=head4 @foldirs = $m->supsubfoldirs($sup,$fol)
$fol :: file without path
=cut
sub supsubfoldirs {
    my ($m,$prog,$sup,$fol) = shift->ppuc('supsubfoldirs',@_);
    opendir DIR, $sup;
    my @foldirs = grep { m(\A\w+\Z) && do { my $dir = catdir $sup, $_;-d $dir and -r catfile $dir, $fol } } readdir DIR;
    closedir DIR;
    $m->dpop($prog,@foldirs);
};


=head3 Function fayl_predoks

Take dok argument or read it from current dir, read the whole chain of superordinated documents from the file system

=head4 Subroutine supdir_set_dokprop

Read document tree from parent directory, return a hash that contains all possibly needed information and is built like $m->{dokprop}
sup_dok2dir already gets info about immediate subdir nodes, but we enrich it hierarchy info.

=cut

sub sup_dokprop ($$) {
    my ($m,$prog,$supdir) = shift->ppuc('sup_dokprop',@_);
    my $dok2dir = $m->sup_dok2dir($supdir); # do { $dok2dir->{dok} = $dir } for all subdoks and and their grpdoks
    my $pfx = $m->pvar(srcfpfx => 1);
    my $fyl = catdir $supdir, $pfx.'subdoks';
    my $supdok = $m->dirdok($supdir);
    my $dokprop = { $supdok => { dir => $supdir } };
    my ($foldir, $fyldir);
    my $doksetpre = sub {
	my ($dok,$predok,$pretyp) = @_;
	my $dir = $dok2dir->{$dok};
	do { $m->uwarn(fdoknodir => d => $dok, f => $fyl);return } unless $dir;
	my %prop = (dir => $dir, typ => $pretyp, dok => $predok);
	$dokprop->{$dok}->{$_} = $prop{$_} for keys %prop;
	1;
    };
    my $typsetpre = sub {
	my $pretyp = shift;
	my @predoks = $m->fayl_postdoks($fyl);
	return unless @predoks;
	my $predok = shift @predoks;
	return unless &$doksetpre($predok,$supdok,$pretyp);
	foreach my $dok (@predoks) { next unless &$doksetpre($dok,$predok,1);$predok = $dok };
	1;
    };
    $m->ustop('parent directory lacks %f', f => $fyl) unless -r $fyl;
    &$typsetpre(3,$fyl,$supdok);
    my @foldirs = $m->supsubfoldirs($supdir, $pfx.'grpdoks');
    foreach my $foldir (@foldirs) { # set attributes of documents that belong to the @foldirs
	$fyldir = catdir $supdir, $foldir;
	$fyl = catdir $fyldir, $pfx.'grpdoks';
	$supdok = $m->dirdok($fyldir);
	&$typsetpre(2,$fyl,$supdok);
    }
    $m->dpop1($prog,$dokprop);
};

sub topinddokp { # whether at top of tree; mark as topdok if found to be one
    my ($m,$prog,$lihs,$dok,$dir,%opts) = shift->opuc('topinddokp',[qw(dok dir)],@_);
    my $pfx = $m->pvar(srcfpfx => 1);
    my $topinddok = $opts{topinddok} || 'topdok';
    my $fyl = $m->topinddok_fayl($lihs,$dok,$dir,$topinddok);
    my $topinddoks = $topinddok.'s';
    my $topinddokp = $topinddok.'p';
    return $m->dpop($prog) unless $m->{$topinddoks}->{$dok} or $m->{dokprop}->{$dok}->{$topinddokp} or -r $fyl;
    touch $fyl;
    $m->{$topinddoks}->{$dok} = 1;
    $m->{dokprop}->{$dok}->{$topinddokp} = 1;
    $m->dpop1($prog,1);
};
=head4 @doks = $m->fayl_predoks_sub($opts,@doks)
=cut
sub fayl_predoks_sub {
    my ($m,$prog,$opts,@doks) = shift->ppuc('fayl_predoks_sub',@_);
    return $m->dpop($prog) unless @doks;
    $opts ||= {};
    my $topinddok = $opts->{topinddok} || 'topdok';
    my $topinddoks = $topinddok.'s';
    my $topinddokp = $topinddok.'p';
    my $dok = shift @doks;
    $m->pstop(funnovar => v => 'dok') unless $dok;
    my $dir = $m->{dokprop}->{$dok}->{dir};
    $m->pstop('no dir for dok %d in dokprop', d => $dok) unless $dir;
    my $supdir = dirname $dir;
  RADIKDIR: {
      my $radikdir = catdir '';
      last unless $supdir eq $radikdir;
      $supdir = $m->{cache}->{primdir};
      last unless $dir eq $supdir;
      return $m->dpop($prog, @doks) if $m->topinddokp($dok, $dir, topinddok => $topinddok);
      $m->ustop('Document root dir must be misconfigured, refusing endless parent search from %d upwards', d => $dir);
      # return $m->dpop($prog, @doks);
    };
    my $prop = {};
    my $dokprop = $m->sup_dokprop($supdir);
    my $kmdfun = sub { @_ };
  KMDFUN: {
      local $_ = $opts->{kmdfun};
      last unless $_;
      if ('list' eq $_) { $kmdfun = sub { my ($dok,$prop) = @_;return unless $prop->{dir};print $prop->{dir}, "\n" } }
      elsif ('info' eq $_) { $kmdfun = sub { my ($dok,$prop) = @_;return unless $prop->{dir};print join("\t", $dok, $prop->{dir}, $prop->{typ}, $prop->{dok}), "\n" } }
      elsif ('putdok' eq $_) { 
	  $kmdfun = sub { 
	      my ($dok,$prop) = @_;
	      return unless $dok;
	      $m->put('mlhtdok', { dok => $dok }, doktmp => 'now()');
	      return unless $prop->{typ} and $prop->{dok} and $prop->{dir};
	      $m->upd('dokprop', { predok => $prop->{dok}, pretyp => $prop->{typ} }, predok => '');
	      my $doknom = basename $prop->{dir};
	      $m->put('dokprop', { dok => $dok}, pretyp => $prop->{typ}, predok => $prop->{dok}, doknom => $doknom) } } 
      else { $m->pstop('unknown kmdfun %k in routine %r', k => $_, r => $prog) };
    };
  PRE: {
      $prop = $dokprop->{$dok};
      $m->ustop(notopnoprop => n => $dok, a => $supdir) unless $prop;
      $dir = $prop->{dir};
      $m->pstop('unable to obtain directory of file chain node %n from supdir %d', n => $dok, d => $supdir) unless $dir;
      &$kmdfun($dok,$prop);
      $m->{dokprop}->{$dok}->{$_} = $prop->{$_} for keys %$prop;
      unshift @doks, $dok if -r $dir and -d $dir and $m->noninfinilup($dok, @doks);
      return $m->dpop($prog,@doks) if $m->topinddokp($dok, $dir, topinddok => $topinddok);
      $dok = $prop->{dok};
      last unless $dok;
      redo;
    };
    @doks = $m->fayl_predoks_sub($opts,@doks);
    $m->dpop($prog, @doks);
};

sub dirfyls {
    my ($m,$prog,$dir) = shift->dpuc('dirfyls',@_);
    my $dh;opendir $dh, $dir;
    my @fls = grep { ! m(\A\.{1,2}\Z) } readdir $dh;
    closedir $dh;
    $m->dpop($prog,@fls);
};

sub fayl_predoks {
    my ($m,$prog,$dok,%opts) = shift->ppuc('fayl_predoks',@_);
    my $pfx = $m->pvar(srcfpfx => 0) || $m->set_srcfpfx;
    my $dir = $opts{dir};
  DIR2DOK2DIR: { # file:/phm/24/01/08/sig/_lng.phm_pub_sig240108.txt::dir2dok2dir
      do { $m->pwarn(funnovar => d => 'dir');$dir = $m->dir2dir } unless $dir;
      do { $m->pwarn(funnovar => d => 'dok');$dok = $m->dir2dok($dir) } unless $dok;
      $m->pstop(funnovar => v => 'dok') unless $dok;
      $dir ||= $m->db_dokdir($dok);
    };
    my $ddir = $m->{dokprop}->{$dok}->{dir};
    return $m->Wpop0($prog, u => doknodir => d => $dok) unless $dir or $ddir;
  NDIR: {
      last unless $dir;
      $m->uwarn('change dir of dok %d from %e to %f', d => $dok, e => $ddir, f => $dir) if $ddir and $dir and not $ddir eq $dir;
      $m->{dokprop}->{$dok}->{dir} = $dir;
    };
    $dir ||= $ddir;
    $m->ustop(funnvar => v => 'dir') unless $dir;
    return $m->Wpop0($prog, u => dirnodokfyls => d => $dir, D => $dok) unless grep { m(\A$pfx\w{3}\.$dok\.txt\Z) } $m->dirfyls($dir);
    $m->set_topdoks;
    my @doks = $m->fayl_predoks_sub(\%opts, $dok);
    $m->dpop($prog,@doks);
};


=head3 Function daba_predoks

Take dok argument, read the whole chain of superordinated documents from the database.

=cut

sub daba_predoktyp {
    my ($m,$prog,$dok) = shift->ppuc('daba_predoktyp',@_);
    my ($predok, $pretyp) = $m->get_record('dokprop', { dok => $dok }, [ 'predok', 'pretyp' ]);
    $m->dpop($prog,$predok,$pretyp);
}
sub noninfinilup { # check for infinite loop, first element must not exist in rest of argument list
    my ($m,$prog,$elm,@elms) = shift->ppuc('noninfinilup',@_);
    my $infilup = grep { $_ eq $elm } @elms;
    $m->ustop(infinilup => e => $elm, L => $m->koniug_et(@elms)) if $infilup;
    $m->dpop1($prog,1);
};
sub daba_predoks {
    my ($m,$prog,$lihs,$dok,%opts) = shift->opuc('daba_predoks',[qw(get_dok)],@_);
    my $topinddok = $opts{topinddok};
    my $topinddoks = $topinddok.'s'; # 'topdoks'
    my $topinddokp = $topinddok.'p'; # 'topdokp'
    $m->set_alidoks;
    $dok = $m->alidok($dok, lihs => $lihs);
    $m->set_topdoks;
    my $predok = $dok;
    my $pretyp = 3;
    my @predoks = ();
    my $topdoks = 0;
    #150321 $m->set_alidoks;
    #150321 PRE: while (1) 
  PRE: {
      $dok = $predok;
      #150321 my $topdokp = $pretyp == 3;
      last if $m->{$topinddoks}->{$dok} || $m->{dokprop}->{$dok}->{$topinddokp};
      ($predok, $pretyp) = $m->daba_predoktyp($dok);
      last if !$predok;
      #150323 $predok = $m->alidok($predok);
      unshift @predoks, $predok if $m->noninfinilup($predok, @predoks);
      my %prop = (dok => $predok, typ => $pretyp);
      $m->{dokprop}->{$dok}->{$_} = $prop{$_} for keys %prop;
      redo;
    };
    $m->dpop($prog,@predoks);
};

=head3 Function daba_postdoks

Take dok argument, read from the database the chain of subordinated documents as far as they belong into a menu.

=cut

sub daba_postdoks {
    my $m = shift;
    $m->dpuc('daba_postdoks', @_);
    my $dok = shift;
    $m->set_alidoks;
    $dok = $m->alidok($dok);
    my @doks = ();
    while (1) {
	my $predok = $dok;
	($dok) = $m->get_record('dokprop', { predok => $predok, pretyp => 1 }, 'dok');
	last unless $dok;
	$dok = $m->alidok($dok);
	$m->ustop('infinite loop in document hierarchy: document %d appearing a second time in chain %D', d => $dok, D => \@doks) if grep { $_ eq $dok } @doks;
	push @doks, $dok;
	$m->{dokprop}->{$dok} = { dok => $predok, typ => 1 };
    };
    $m->dpop('daba_postdoks', @doks);
    return @doks;
};

=head2 Generation of Menus

Used by nav2html(1), makedoksrow(1)

=head3 Function menu_subdoks

Take a dok, return the flat list of direct subordinates, i.e. subdoks or grpdoks, of this dok.

=cut

sub menu_subdoks {
    my ($m,$prog,$dok) = shift->ppuc('menu_subdoks',@_);
    $dok ||= $m->get_dok;
    my $lwd = '';
    my $dir = '';
  DOK: {
      last if $dok eq $m->pvar('dok');
      $dir = $m->dokdir($dok);
      return $m->Wpop0($prog, p => dokdirnosubs => d => $dir, n => $dok) unless -d  $dir;
      ($dir,$lwd) = $m->chwd($dir);
    };
    my @doks = $m->get_doks(undef, DabaP => 1);
    $m->chwd($lwd) if $lwd;
    $m->dpop($prog,@doks);
};

=head3 Function dokmenu_item

Take a dok, return its entry for the left-hand navigation menu of the HTML version.

=cut

sub dokmenu_item {
    my $m = shift;
    $m->dpuc('dokmenu_item', @_);
    my $dok = shift;
    my ($url, $lab) = $m->dok2urllab($dok);
    do { $m->dpop;return } unless length $url and length $lab;
    my $entry = $m->hreftext($url, $lab);
    $m->dpop1('dokmenu_item', $entry);return $entry;
};

=head3 Function dokmenu_items

Format the menu_subdoks for an HTML menu.

=cut

sub dokmenu_items {
    my $m = shift;
    $m->dpuc('dokmenu_items', @_);
    my $dok = shift || $m->get_dok;
    my @doks = $m->menu_subdoks($dok);
    my @items = map { $m->dokmenu_item($_) } @doks;
    $m->dpop('dokmenu_items', @items);return @items;
};

=head3 Function listitem

Format an item for a list used in an HTML menu.

Higher level applications can tweak this by setting the $m->{lifmt} variable.

=cut

sub listitem {
    my $m = shift;
    $m->dpuc('listitem', @_);
    my $str = shift;
    my $item = sprintf $m->{lifmt}, $str;
    $m->dpop1('listitem', $item);return $item;
};

=head3 Function dokmenu

Format the whole subordinate menu of the current document and return it.

=cut

sub dokmenu {
    my $m = shift;
    $m->dpuc('dokmenu', @_);
    my $dok = shift || $m->pvar('dok');
    my (@items) = $m->dokmenu_items($dok);
  NO_ENTRIES: {
      $m->dpuc('no_entries', @items);
      do { $m->dpop;last } if @items;
      $m->dpop('dokmenu');return;
  };
    my $menu = join "\n", map { $m->listitem($_) } @items;
    $menu = $m->enclose('<ul>'."\n", '</ul>'."\n", $menu);
    $m->dpop1('dokmenu', $menu);
    return $menu;
};

=head3 Function predoks

The chain of superordinate documents that belong into the menu, starting from the top, ending at the document given in arg1 or my current dok.

This chain is a bit thinner than the full chain.  As we move up the directory hierarchy, only those nodes from which sub-hierarchies are forked out remain important.

We distinguish between level 3 and level 2 sub-hierarchies (subdoks and grpdoks).  When moving up the hierarchy, level 2 becomes irrelevant as soon as we have reached a level 3 fork.

At the document itself we are at level 1 (sequenced leaves of same node).  We list the preceding leaves, before that the superordinate groups, before that the superordinate directories.

We can set the initial level as an option 

    typ_min => 1

in arg2ff, which is a hash of options.

=cut

sub predoks ($;$%) {
    my ($m,$prog,$dok,%opts) = shift->ppuc('predoks',@_);
    my $dir = $opts{dir};
    ($dok,$dir) = $m->setdokdir($dok,$dir);
    $dok = $m->alidok($dok);
    my @predoks = $m->get_predoks($dok, %opts);
    my $i = $#predoks;
    my @doks = ();
    $opts{typ_min} ||= 1;
    my $predok = '';
    my $pretyp = 0;
    while ($i >= 0) {
	$predok = $predoks[$i];
	$m->pstop('empty member in predoks chain') unless length $predok;
	$pretyp = $m->{dokprop}->{$dok}->{typ} or $m->pstop('no pretyp found for dok %d with predok %p', d => $dok, p => $predok);
	next if $pretyp < $opts{typ_min};
	$opts{typ_min} = $pretyp if $pretyp > $opts{typ_min};
	unshift @doks, $predok;
    } continue { $i--;$dok = $predok };
    $m->dpop($prog,@doks);
};

=head3 Function postdoks

Posterior documents of the current hierarchy level, as far as they ought to appear in a menu.

=cut

sub postdoks ($;$) {
    my $m = shift;
    $m->dpuc('postdoks', @_);
    my $dok = shift || $m->set_dok;
    #150321 do { $m->dpop;return } if $m->{topdoks}->{$dok};
    my @doks = $m->daba_postdoks('_grpdoks');
    $m->dpop('postdoks', @doks);
    return @doks;
};

=head2 Support for various dokfs operations (set alias, delete)

=head3 Function set_alias

set an alias, e.g. from the commandline, and store it in the database.

=cut
sub db_dokdir {
    my ($m,$prog,$lihs,$dok,%opts) = shift->opuc('db_dokdir',[qw(nom)],@_);
    my $url = $m->db_dok2absurl($dok,%opts);
    my $dir = $m->url2dir($url);
    $m->dpop1($prog,$dir);
};
sub set_alias {
    my ($m,$prog,$lihs,$alidok,$dok,%opts) = shift->opuc('set_alias',[qw(nom dok)],@_);
    my @rek = ();
  ALIDOK_EXISTS: {
      my $url = $m->db_dok2absurl($alidok);
      last unless $url;
      $m->ustop('cannot set alias %a to %d, alias exists as a document with url %u', a => $alidok, d => $dok, u => $rek[0]);
  };
  DOK_NOT_EXISTS: {
      @rek = $m->get_record('mlhtdok', { dok => $dok }, 'doktmp');
      last if @rek;
      last if $dok eq $m->pvar('dok') and $m->put('mlhtdok', { dok => $dok }, doktmp => 'now()', dokurl => $m->dir2url);
      $m->ustop('document %d not in database', d => $dok);
    };
    my $num = $m->put('doktexts', { dok => $alidok }, varnom => 'alias', varval=> $dok, valsymp => 'true');
    $m->pstop('database operation on table doktexts with dok %d and alias %a affected no records', d => $dok, a => $alidok) if !$num;
    $m->dpop1($prog,$num);
};

=head3 Function rmtalias

delete an alias from the database.

Invokable from the commandline with rmtalias(1)

=cut

sub rmtalias {
    my $m = shift;
    $m->dpuc('rmtalias', @_);
    my $alidok = shift;
  NO_ALIDOK: {
      $m->dpuc('no_alidok', $alidok);
      do { $m->dpop;last } if $alidok =~ m(\A[\w\_]+\Z);
      $m->dpop('rmtalias');return;
    };
    my $num = $m->delete('doktexts', { dok => $alidok, varnom => 'alias' });
    $m->vecho('deleted %n records of alias %d', n => $num, d => $alidok);
    $m->dpop1('rmtalias', $num);return $num;
};

=head3 Function rmdok

Erase a given document and all related info from the database (DBDEL) and from the doksfile (subdoks, grpdoks).
PREPOST: Leave no hole in the document chain, connect the preceding to the following.
SUBDOK: Refuse to erase a document that has subdocuments.

=cut

sub rmdok {
    my ($m,$prog,$lihs,$dok,%opts) = shift->opuc('rmdok',[qw(nom)],@_);
    my $pfx = $m->pvar(srcfpfx => 1);
    my $force = $m->pvar(force => 0);
    $m->ustop_or_warn($force, 'invalid document name %d', d => $dok) unless $dok =~ $m->{konfig}->dok_regexp;
  SUBDOK: {
      my ($subdok) = $m->get_record('dokprop', { predok => $dok, pretyp => [ 'in', 2, 3 ] }, 'dok');
      last if !$subdok;
      $m->ustop('node %d has subnodes %e etc, remove them first', d => $dok, e => $subdok) unless $force;
      $m->rmdok($subdok,%opts);
    };
    my $doksfile = eval { $m->doksfile($dok) }; # save this before changing database
    return $m->Wpop0($prog, p => doknodoksf => D => $dok, m => $@) if $@;
  DOKSFAYL: { # more opportunities for errors before changing database
    GETFAYL: {
	last if $doksfile;
	$m->uwarn('no proper doksfile found');
	($doksfile) = glob $pfx.'*doks';
	do { $m->uwarn('can not even find one by globbing');last DOKSFAYL } if !$doksfile;
	$m->uwarn('guess-picked %f from current directory', f => $doksfile);
      };
      $m->ustop('doksfile %f not writable', f => $doksfile) if ! -w $doksfile;
      $m->rewrite_doksfile($doksfile, 'rm', $dok);
    };
  PREPOST: { # connect preceding to following document
      my ($postdok) = $m->get_record('dokprop', { predok => $dok, pretyp => 1 }, 'dok');
      $m->vecho('no postdok found for %d', d => $dok) unless $postdok;
      my ($predok, $pretyp) = $m->get_record('dokprop', { dok => $dok }, [ 'predok', 'pretyp' ]);
      $m->uwarn('no predok found for document %d', d => $dok) unless $predok;
      $m->uwarn('no pretyp found for document %d', d => $dok) unless $pretyp;
      last unless $predok and $pretyp and $postdok;

=pod
The uniqueness constraint on predok forces us to set it to null for the document that we later delete.
We could also delete it now, but what if one day another table (in konfig.doktabs) depends on dokprop rather than mlhtdok?
Preferrably that should not happen, but let us be prudent.
=cut
      eval { $m->put('dokprop', { dok => $dok }, predok => '', pretyp => 0) };
      $m->ustop_or_warn($force, 'failed to set predok of dok %d to null: %m', d => $dok, m => $@) if $@;
      eval { $m->put('dokprop', { dok => $postdok }, predok => $predok, pretyp => $pretyp) };
      $m->ustop_or_warn($force, 'failed to connect %p and %q in type %t chain: %m', p => $predok, q => $postdok, t => $pretyp, m => $@) if $@;
    };
  DBDEL: {
      my $maxrows = 1;
      $m->setpvar(maxrows => 0);
      my $rows = $m->sql_query(qq{update dokprop set predok = null where predok = '$dok'}); 
      $m->decho('UPDATE %d', $rows);
      $m->delete('lnsig', { $_ => $dok }) for qw(tra sig);
      foreach my $tab (@{$m->{konfig}->doktabs}) {
	  my $dokvar = $m->{konfig}->doktabs_dok->{$tab} || '';
	  my @dokvars = split m(\W+), $dokvar;
	  $dokvars[0] ||= 'dok';
	  MAXROWS: {
	      do { $maxrows = 0;last } if $force;
	      do { $maxrows = $m->{konfig}->doktabs_maxrows->{$tab};last } if exists $m->{konfig}->doktabs_maxrows->{$tab};
	      $maxrows = 1;
	  };
	  foreach $dokvar (@dokvars) {
	      eval { $m->delete($tab, { $dokvar => $dok }, maxrows => $maxrows) };
	  };
	  $m->pstop_or_warn($force, 'failed to delete document %d from table %t: %m', d => $dok, t => $tab, m => $@) if $@;
      };
      $m->setpvar(maxrows => $maxrows);
    };
    $m->dpop1($prog,1);
};

=head3 Function deldok

=cut

sub deldok ($$) {
    my $m = shift;
    $m->pwarn("using deprecated name deldok, please change to rmdok");
    $m->rmdok($@);
};

=head rmtop

Strip document of its topdok status and remove any template files that testified this status.

=cut

sub rmtop ($$) {
    my $m = shift;
    $m->dpuc('rmtop', @_);
    my $dok = shift || $m->get_dok;
    die "cant set dok" unless length $dok;
    $m->delete('dokflags', { dok => $dok, varnom => 'topdok' });
    $m->delete('topdok', { topdok => $dok });
  FILES: {
      my @files = ();
      foreach my $ext (qw(xhtml tex css png jpg)) { my $fi = join '.', $dok, $ext;next unless -e $fi;push @files, $fi };
      $m->dpuc('files', @files);
      do { $m->dpop;last } unless @files;
      $m->svn_delete(\@files, 1);
      $m->svn_commit(@files);
      $m->dpop;
    };
    $m->dpop1('rmtop', $dok);
    return $dok;
};

=head3 Function link_target

=cut

sub link_target {
    my $m = shift;
    $m->dpuc('link_target', @_);
    my $obj = shift;
    do { $m->dpop('link_target', 0, { err => 'no_obj' });return } unless $obj;
    do { $m->dpop('link_target', 0, { err => 'bad_obj'});return } unless -e $obj;
    $obj = readlink $obj while -l $obj;
    $m->dpop1('link_target', $obj);
    return $obj;
};

=head3 Function set_pwd

Set present working directory $m->pvar('pwd') with ideal path name or whatever is given to it, resolving links and checking sanity.

=cut

sub set_pwd {
    my ($m,$prog,$lihs) = shift->lpuc('set_pwd',@_);
    my $pwd = $m->pvar('pwd');
    return $m->dpop1($prog,$pwd) if $pwd;
    $m->{progvars}->{cwd} = '';
    $pwd = $m->get_dir($lihs);
    $m->setpvar(pwd => $pwd, lihs => $lihs);
    $m->setpvar(cwd => $pwd, lihs => $lihs);
    $m->dpop1($prog,$pwd);
};

=head3 Function dirdok

return the dok (document identifier) found in the given dir (directory).

=cut

sub dir2dok ($$) {
    my ($m,$prog,$dir) = shift->ppuc('dir2dok',@_);
    $dir ||= $m->dir2dir;
    $m->ustop(dirnodir => d => $dir) unless -d $dir;
    my $pfx = $m->get_srcfpfx(dir => $dir);
    my %doksh = ();
    my $dok = '';
    opendir DIR, $dir;
    for (readdir DIR) {
	($dok) = m(\A$pfx(?:pre|lng|dok)\.(\w+)\.txt\Z);
	next unless $dok;
	++$doksh{$dok};
    };
    closedir DIR;
    my @doks = keys %doksh;
    $m->ustop(dokssquatdir => { d => $dir, D => \@doks }) if $#doks > 0;
    $dok = shift @doks;
    return $m->Wpop0($prog, d => dirnodok => d => $dir) unless $dok;
    $m->{dokprop}->{$dok}->{dir} ||= $dir;
    $m->dpop1($prog,$dok);
};
sub dirdok ($$) {
    my ($m,$prog,$dir) = shift->ppuc('dirdok',@_);
    $dir ||= $m->get_cwd;
    $dir =~ s(\/+\Z)(); 
    my ($fayl, $regex) = ();
    my $pfx = $m->pvar(srcfpfx => 1);
    my $dok = $m->dir2dok($dir,$pfx);
    $m->dpop1($prog,$dok);return $dok;
};

=head3 Function rmtdirsub

take fol (directory leaf) argument, erase the document found at dir from the file system and the database.
%arg2ff are options, including

    force: move ahead recklessly

This is normally invoked only via a recursive version C<rmtdir> which also removes subdirectories.

=cut

sub rmtdirsub ($$) {
    my $prog = 'rmtdirsub';my $m = shift;$m->dpuc($prog,@_);
    my $fol = shift;
    my $pwd = $m->set_pwd;
    eval { $m->svn_update };
    my %opts = @_;
    $opts{force} = $m->{konfig}->force unless exists $opts{force};
    my $dir = catdir $pwd, $fol;
    my $dok = $opts{dok} || eval { $m->dirdok($dir) };
    if ($dok) {
	eval { $m->rmdok($dok) };
	$m->uwarn('kann Dokument %d nicht löschen: %m', d => $dok, m => $@) if $@;
    } else {
	$m->uwarn('Im Ast %f ist kein Dokument zum Löschen vorhanden', f => $fol);
    };
    return $m->Wpop1($prog, u => nodir => d => $dir, f => $opts{force}) unless -d $fol;
    $m->ustop(nordir => d => $dir) unless -r $fol;
    $m->ustop(nowdir => d => $dir) unless -w $fol;
    foreach my $lfol (grep { -l $_ and $fol eq readlink $_ } $m->dirfyls('.')) {
	$m->svn_delete($lfol);
    };
    $m->svn_delete($fol);
    $m->svn_commit();
    $m->uwarn('object %f is still present', f => $fol) if -e $fol;
    $m->dpop1($prog,1);return 1;
};

=head3 Function rmtdir

Recursively remove a document along with its subdocuments.
Invocable from commandline as 

    rmtdir <name>

=cut

our @nondok_dirs = ('.', '..', '.svn'); 

sub rmtdir ($$) {
    my $prog = 'rmtdir';my $m = shift;$m->dpuc($prog,@_);
    my $fol = shift;
    my $dh = undef;
    my $ok = opendir $dh, $fol;
    $m->ustop('no directory %d to remove', d => $fol) unless $ok or $m->pvar('force');
    if ($ok) {
	my ($dir, $lwd) = $m->chwd($fol);
	$m->ustop('chwd returned strange results %d and %w', d => $dir, w => $lwd) unless $dir and -d $dir and $lwd and -d $dir;
	chdir $dir;
	while (my $fn = readdir $dh) {
	    next unless -d $fn;
	    next if grep { $_ eq $fn } @nondok_dirs;
	    $m->rmtdir($fn);
	};
	$ok = closedir $dh;
	chdir $lwd or $m->ustop('cant change back to directory %d', d => $lwd);
    };
    $ok = $m->rmtdirsub($fol);
    $m->dpop1($prog, $ok);return 1;
};

sub deltdok ($$) {
    my $m = shift;
    $m->pwarn("using deprecated name deltdok, please change to rmtdir");
    $m->rmtdir($@);
};

=head3 Functions url_fayl, dok_fayl, nav_fayl, dok_lng_faylz, lng_tmk_faylz

TODO: These must be connected to the configurable file name templates unifnom, mulfnom, lngfnom etc

=head4 url_fayl

=cut

sub url_fayl ($;) {
    my $m = shift;
    my $lang = shift;
    my $pfx = $m->pvar(srcfpfx => 1);
    my $fayl = $pfx.'url';
    my $dok = $m->pvar('dok');
    return join '.', $fayl, $dok, 'txt' unless $lang;
    return join '.', $fayl, $dok, $lang, 'txt';
};

=head4 tmplang_fayl

=cut

sub tmplang_fayl ($;) {
    my $m = shift;
    my $pfx = $m->pvar(srcfpfx => 1);
    return $pfx.'tmplang';
};

=head4 Function dok_fayl

=cut

sub dok_fayl ($) {
    my $m = shift;
    my %repl = @_;
    my $pfx = $m->pvar(srcfpfx => 1);
    my $dok = $m->pvar(dok => 1);
    $repl{p} ||= $pfx;
    $repl{d} ||= $dok;
    return $m->hsprintf($m->{konfig}->mulfnom, %repl);
};
sub prv_fayl ($) {
    my $m = shift;
    my %repl = @_;
    my $pfx = $m->pvar(srcfpfx => 1);
    my $dok = $m->pvar(dok => 1);
    $repl{p} ||= $pfx;
    $repl{d} ||= $dok;
    return $m->hsprintf($m->{konfig}->prvfnom, %repl);
};

=head4 Function nav_fayl

=cut

sub nav_fayl ($) {
    my $m = shift;
    my %repl = @_;
    my $pfx = $m->pvar(srcfpfx => 1);
    my $dok = $m->pvar(dok => 1);
    $repl{p} ||= $pfx;
    $repl{d} ||= $dok;
    return $m->hsprintf($m->{konfig}->navfnom, %repl);
};


=head4 Function lng_fayl

=cut

sub lng_fayl {
    my $prog = 'lng_fayl';my $m = shift;$m->dpuc($prog, @_);
    my %repl = @_;
    my $pfx = $m->pvar(srcfpfx => 1);
    my $dok = $m->pvar(dok => 1);
    $repl{d} ||= $dok;
    $repl{p} ||= $pfx;
    my $fayl = $repl{l} ? $m->hsprintf($m->{konfig}->lexfnom, %repl) : $m->hsprintf($m->{konfig}->lexfnom0, %repl);
    $m->dpop1('lng_fayl', $fayl);
    return $fayl;
};

=head4 Function antefayl

C<_pre.$dok.$lang.txt> or, when $lang is null, C<_pre.$dok.txt>

=cut

sub antefayl {
    my $m = shift;
    $m->dpuc('antefayl', @_);
    my $dok = shift;
    my $lang = shift;
    my $dir = '.';
    if ($dok) {
	$dir = $m->dokdir($dok);
    } else {
	$dok = $m->pvar('dok');
    };
    my $pfx = $m->pvar(srcfpfx => 1);
    my $fayl = $lang ? $m->hsprintf($m->{konfig}->antefnom, p => $pfx, d => $dok, l => $lang) : $m->hsprintf($m->{konfig}->antefnom0, p => $pfx, d => $dok);
    $fayl = catfile $dir, $fayl;
    $m->dpop1('antefayl', $fayl);
    return $fayl;
};

=head4 Function dir_srclang

get first language of current document if there is one

=cut

sub dir_srclang {
    my $m = shift;
    $m->dpuc('dir_srclang', @_);
    my $srclang = eval { $m->{langs}->[0] };
    return $srclang if $srclang;
    ($srclang) = $m->dirlangs;
    $m->dpop1('dir_srclang', $srclang);
    $srclang;
};

=head4 Function dok_pre_lng_faylz

All vocuabulary files belonging to one document, language-neutral before language-specific, template-specific before document-specific.

The first position must be occupied by a prependable file and, if no such file is available, by an empty string.

rank_sufiks is the rank suffix '?+', '' or '?-' that specifies which variable assignments (for unimportant nodes: exported assignements only, for normal nodes: all assigments except unexported ones, for important nodes: all assignements including unexported ones) should be read from the concerned file.  For the appended vocabulary files, only those of the current node $m->pvar('dok') are important (of high importance), the other ones are unimportant (of low importance).  Template files and prepended (antefnom) files are of normal importance.

It is recognised in A2E::Tmplfil(3) by riid_tmplvars_fayl and used there by tmplini, where more explanations are found.

Bells & Whistles:

no_redefp_rank :: add ?+ to file name so as to make all its variable assignments, even those with ?= ?:=, overwrite existing values in file:/adv/perl/A2E/Tmplfil.pm.tmpl::tmplini_setnomval; this is done for the antefayl0 (_pre.*.txt file) of the current document and could be useful for tmpl-related files (which however work well without ?= assignments anyway).

=cut

sub dok_pre_lng_faylz { 
    my ($m,$prog,$lihs,$lang,$dok,%optz) = shift->opuc('dok_pre_lng_faylz',[qw(lang_let dok)],@_);
    my $dir = $m->dokdir($dok);
    my $topdok = $optz{topdok} || $m->pvar(topdok => 1);
    my $mydok = ($dok eq $optz{dok}) ? 1 : 0;
    my $rank = $optz{norank} ? 0 : 1;
    my $no_redefp_rank = '?+';
    my $get_ranksfx = sub {
	return if $mydok;
	return if $optz{predoks};
	'?-';
    };
    my $ranksfx = &$get_ranksfx;
    my ($fol, $fayl, @lng_faylz, @pre_faylz) = ();
    my $llng_fnom = $m->{konfig}->lexfnom or $m->pstop(funnovar => v => 'lexfnom');
    my $lng_fnom = $m->{konfig}->lexfnom0 or $m->pstop(funnovar => v => 'lexfnom0');
    my $pre_fnom = $m->{konfig}->antefnom0 or $m->pstop(funnovar => v => 'antefnom0');
    my $lpre_fnom = $m->{konfig}->antefnom;
    my $pfx = $m->get_srcfpfx(dir => $dir) || $m->pvar(srcfpfx => 1) || $m->pstop('dok_pre_lng_faylz failed to get srcfpfx');
  TYPS: {
    ANTE0: {
	last if $optz{nonpre};
	$fol = $m->hsprintf($pre_fnom, p => $pfx, d => $dok);
	$fayl = catfile $dir, $fol;
	last if !-r $fayl;
	$fayl .= $no_redefp_rank if $mydok and $rank;
	unshift @pre_faylz, $fayl;
      };
      last if $optz{nonlng};
    SRCLANG: { # source language vocabulary; in any case include this as normal-rank file at the level of the current document only
	last if $optz{nonlng};
	last unless $dir eq '.' and $optz{par};
	last if $optz{nosrclang};
	my $srclang = $m->dir_srclang;
	last if !$srclang or $srclang eq $lang;
	$fol = $m->hsprintf($llng_fnom, p => $pfx, d => $dok, l => $srclang);
	$fayl = catfile $dir, $fol;
	last if !-r $fayl;
	push @lng_faylz, $fayl;
      };
    LANG: { # _lng.$dok.$ll.txt
	last if $optz{nonlng};
	last unless $lang;
	$fol = $m->hsprintf($llng_fnom, p => $pfx, d => $dok, l => $lang);
	$fayl = catfile $dir, $fol;
	last if !-r $fayl;
	$fayl .= $ranksfx;
	push @lng_faylz, $fayl;
      };
    LANG0: { # _lng.$dok.txt
	last if $optz{nonlng} or $optz{nolng0};
	last unless $mydok or $optz{par};
	last unless $lang;
	$fol = $m->hsprintf($lng_fnom, p => $pfx, d => $dok);
	$fayl = catfile $dir, $fol;
	last if !-r $fayl;
	$fayl .= $ranksfx;
	if ($m->{konfig}->lng_faylz_mul_uni) { unshift @lng_faylz, $fayl } else { push @lng_faylz, $fayl };
      };
    ANTE: { # _pre.$dok.$ll.txt
	last unless $lang;
	die 'vocabulary preset template --antefnom not set' unless $lpre_fnom;
	$fol = $m->hsprintf($lpre_fnom, p => $pfx, d => $dok, l => $lang);
	$fayl = catfile $dir, $fol;
	last if !-r $fayl;
	unshift @pre_faylz, $fayl;
      };
    };
    $m->dpop($prog,\@pre_faylz,\@lng_faylz);
};
sub dok_pre_faylz {
    my ($m,$prog,$lihs,$dok,%optz) = shift->opuc('dok_pre_faylz',[qw(dok)],@_);
    $optz{nonlng} = 1;
    my ($pre,$lng) = $m->dok_pre_lng_faylz('',$dok,%optz);
    $m->dpop($prog,@$pre);
};
sub dok_lng_faylz {
    my ($m,$prog,$lihs,$lang,$dok,%optz) = shift->opuc('dok_pre_faylz',[qw(lang dok)],@_);
    $optz{nonlng} = 1;
    my ($pre,$lng) = $m->dok_pre_lng_faylz($lang,$dok,%optz);
    $m->dpop($prog,@$lng);
};

=head4 ($prez,$tmkz) = $m->tml8tmpl7pre8tmk3dirs($tml,$prez,$tmkz): Recursively add superior template directories to head of directory list

$tml => 'latex'
$tmpl => 'oas_aamm'
$prez => []
$tmkz = []

also add $tml subdirectories of these, e.g. /opt/a2e/share/tmpl/mlht/a2e/sig_aammdd/latex
add to the listrefs that are indirectly returned
always push at the directory level, the unshifting is done at the file level in lng_tmk_faylz of which this is a subroutine.
SEMIOTICS of numerals
	8 eight => and, okt => ott => et
	7 sept => set
	2 two/du => to
	1,0 parenthesis (on off)
	3 tri => atTRIbutive relation
	4 reverse of 3 i.e. appositional relation (subordination to next, similar to apposed group with conjunction 'for')

other potential uses
	5 like 4 but 4 being 'for' (purpose apposition) and 5 'from' (origin apposition)
	9 negation: a non/without b.

2,7 are of lowest bonding force, 8 of highest, 3,4 intermediate.  0,1 can be used to force association.

=cut

sub tml8tmpl7pre8tmk3dirs {
    my ($m,$prog,$lihs,$tml,$tmpl,$prez,$tmkz) = shift->opuc('tml8tmpl7pre8tmk3dirs',[[qw(tml_get tmpl_let prez tmkz)],{ prez => 'lstr_get', tmkz => 'lstr_get' }],@_);
    my %olddirp = ();
    my @dirnoms = qw(doktmpldir tmplappdir);
    push @dirnoms, 'tmpldir' if $tmpl;
    foreach my $dirnom (@dirnoms) {
	my $dir = $m->pvar($dirnom => 1);
	next unless -d $dir;
        do { push @$prez, $dir;
	     $olddirp{$dir} = 1;
	} unless $olddirp{$dir};
	$dir = catfile $dir, $tml;
	next unless -d $dir;
	do { push @$tmkz, $dir;
	     $olddirp{$dir} = 1;
	} unless $olddirp{$dir};
    };
    $m->dpop($prog,$prez,$tmkz);
};

=head4 Function lng_tmk_faylz

template files with which LNG_FAYLZ starts

=cut

sub pre_tml_lng_tmk_faylz {
    my ($m,$prog,$lihs,$lang,$tmpl,$tml,%optz) = shift->opuc('pre_tml_lng_tmk_faylz',[[qw(lang_let)],[qw(tmpl_let tml_get)]],@_);
    my $predirs = [];
    my $tmldirs = [];
    $m->tml8tmpl7pre8tmk3dirs($tml,$tmpl,$predirs,$tmldirs);
    my $prez = [];
    my $lngz = [];
    my $tmkz = [];
    my $dir2faylz = sub {
	my ($dir,$tmlp) = @_;
	my $nonpre = $tmlp ? 0 : $optz{nonpre};
	my $nonlng = $tmlp ? 0 : $optz{nonlng};
	my $prez = $tmlp ? $tmkz : $prez;
	my $lngz = $tmlp ? $tmkz : $lngz;
	my $fib = '';
	my $fi = '';
      TYPS: {
	  ANTE0: { # 'lang_pre.txt'
	      # last unless $optz{par};
	      last if $nonpre;
	      $fib = $m->hsprintf($m->{konfig}->tmplngantefnom0, t => $tmpl);
	      $fi = catfile $dir, $fib;
	      last unless -r $fi;
	      unshift @$prez, $fi;
	    };
	    last if $nonlng;
	  LANG: { # 'lang.de.txt'
	      last unless $lang;
	      $fib = $m->hsprintf($m->{konfig}->tmplnglangfnom, t => $tmpl, l => $lang);
	      $fi = catfile $dir, $fib;
	      last unless -r $fi;
	      push @$lngz, $fi;
	      last TYPS;
	    };
	  POST: { # 'lang.txt'
	      # last unless $optz{par};
	      $fib = $m->hsprintf($m->{konfig}->tmplngpostfnom, t => $tmpl);
	      $fi = catfile $dir, $fib;
	      last unless -r $fi;
	      push @$lngz, $fi;
	    };
	};
    };
    unless ($optz{nonpre} && $optz{nonlng}) {
	foreach my $dir (@$predirs) { 
	    &$dir2faylz($dir,0);
	}
    };
    unless ($optz{nontml}) { 
	foreach my $dir (@$tmldirs) { 
	    &$dir2faylz($dir,1)
	} }; 
    $m->dpop($prog,$prez,$tmkz,$lngz);
};

sub lng_tmk_faylz ($$%) {
    my ($m,$prog,$lang,%optz) = shift->ppuc('lng_tmk_faylz',@_);
    $optz{nonpre} = 1;
    $optz{nontml} = 1;
    my ($prez,$tmkz,$lngz) = $m->pre_tml_lng_tmk_faylz($lang, %optz);
    return $m->dpop($prog) unless $lngz;
    @_ = @$lngz;
    $m->dpop($prog,@_);return @_;
};

sub pre_tmk_faylz ($%) {
    my ($m,$prog,%optz) = shift->ppuc('lng_tmk_faylz',@_);
    $optz{nonlng} = 1;
    $optz{nontml} = 1;
    my ($prez,$tmkz,$lngz) = $m->pre_tml_lng_tmk_faylz('', %optz);
    return $m->dpop($prog) unless $prez;
    @_ = @$prez;
    $m->dpop($prog,@_);return @_;
};
sub tml_tmk_faylz ($%) {
    my ($m,$prog,%optz) = shift->ppuc('tml_tmk_faylz',@_);
    $optz{nonlng} = 1;
    $optz{nonpre} = 1;
    my ($prez,$tmkz,$lngz) = $m->pre_tml_lng_tmk_faylz('', %optz);
    return $m->dpop($prog) unless $tmkz;
    @_ = @$tmkz;
    $m->dpop($prog,@_);return @_;
};

=head4 Function top_fayl

=cut

sub top_fayl ($$) {
    my $prog = 'top_fayl';my $m = shift;$m->dpuc($prog,@_);
    my $lang = shift;
    my $pfx = $m->pvar(srcfpfx => 1);
    my $dok = $m->pvar(dok => 1);
    my $fayl = $m->hsprintf($m->{konfig}->{unifnom}, p => $pfx, d => $dok, l => $lang);
    $m->dpop1($prog,$fayl);return $fayl;
};

=head3 Function lng_faylz

readable: list only files that exist and are readable
list pairs: one language-neutral, one for lang
if not true, list language-dependent files only
nosrclang: Normally, where possible, the source language version is read so as to provide defaults in case no lit is there in the current language.
Set nosrclang true to switch off this behaviour.

=head4 ($prez,$lngz) = $m->pre_lng_faylz($prog,$lang,$dok,%optz): find all vocabulary target dependencies of $dok

up to predoks and lang*.txt config

=cut

sub pre_lng_faylz {
    my ($m,$prog,$lihs,$lang,$Dok,%optz) = shift->opuc('pre_lng_faylz',[qw(lang_let dok)],@_);
    $optz{nosrclang} = !$m->dokprogverpre(400);
    $optz{typ_min} ||= 3;
    my ($prez,$tmkz,$lngz) = $m->pre_tml_lng_tmk_faylz($lang, %optz);
    return $m->dpop($prog,$prez,$lngz) if !$Dok or $optz{tmpl_only};
    my @doks = ();
    push @doks, $m->predoks($Dok, typ_min => $optz{typ_min}, NFaylP => $optz{NFaylP}, DabaP => $optz{DabaP}) if $optz{nonlng};
    push @doks, $Dok;
    $optz{dok} = $Dok;
    foreach my $dok (@doks) {
	my ($pre,$lng) = $m->dok_pre_lng_faylz($lang,$dok,%optz);
      PRE: {
	  last if $optz{nonpre};
	  $m->pstop('pre return value from dok_pre_lng_faylz is not an array ref') unless 'ARRAY' eq ref $pre;
	  unshift @$prez, @$pre;
	  my $prv_fayl = $m->prv_fayl(d => $dok);
	  last unless -r $prv_fayl;
	  unshift @$prez, $prv_fayl;
	};
      LNG: {
	  last if $optz{nonlng};
	  $m->pstop('bad lng return value from dok_pre_lng_faylz') unless 'ARRAY' eq ref $lng;
	  push @$lngz, @$lng;
	};
    };
    $m->dpop($prog,$prez,$lngz);
};
sub lng_faylz ($$$%) {
    my ($m,$prog,$lihs,$lang,$dok,%optz) = shift->opuc('lng_faylz',[qw(lang dok)],@_);
    $optz{nonpre} = 1;
    $optz{nontml} = 1;
    my ($prez,$lngz) = $m->pre_lng_faylz($lang,$dok,%optz);
    $m->dpop($prog,@$lngz);
};
sub pre_faylz ($$%) {
    my ($m,$prog,$lihs,$dok,%optz) = shift->opuc('pre_faylz',[qw(dok)],@_);
    $optz{nonlng} = 1;
    $optz{nontml} = 1;
    my ($prez,$lngz) = $m->pre_lng_faylz('',$dok,%optz);
    $m->dpop($prog,@$prez);
};

=head4 Function faylz_src

Return all sources that a Makefile needs to compile a text chunk index.
This list is slightly different from the argument list of lng_faylz that is fed to the txt2dbm utility for creating the index.
The lng_faylz argument list is given as argument list with arguments containing non-filename given as optional suffixes ?+ ?- ?= after each filename.
Throw out the suffixes and any non-existing files, recursively find and add any files that are sub-invoked by C<include> or C<include_re> statements.
The txt2dbm utility does not need the sub-included files, but Make does need to treat them as sources (so as to check whether they were updated and if so recompile the target text chunk index.

=cut

sub faylz_src {
    my ($m,$prog) = shift->ppuc('faylz_src',@_);
    my $oldfaylp = {};
    my @faylz = ();
    foreach my $fayl (@_) {
	my ($tmp) = $fayl =~ m(\A(.*)\?);    
	$fayl = $tmp if $tmp;
	next unless -f $fayl;
	my @subfaylz = eval { $m->lng_fayl_subfaylz($fayl, oldfaylp => $oldfaylp) };
	$m->ustop('failed to read included files from %f: %m', f => $fayl, m => $@) if $@;
	next unless @subfaylz;
	push @faylz, @subfaylz;
    };
    $m->dpop($prog,@faylz);
};

=head4 &set_dok_lang($dok,$lang?, %opts) => $lang

opts.keys :: lihs

set language of an external document, either to my current lang or to the doc's first lang $dok_langs[0]

=cut
sub set_dok_lang {
    my ($m,$prog,$lihs,$dok,$lang,%opts) = shift->opuc('set_dok_lang',[qw(dok lang)],@_);
    $lang ||= $m->pvar(lang => 1);
    my @dok_langs = $m->get_langs(dok => $dok, lihs => $lihs);
    grep { $_ eq $lang } @dok_langs ? $lang : $dok_langs[0];
};

=head3 Function set_dok_langs

used by Dokdata2db.pm

=cut

sub set_langs {
    my ($m,$prog,$lihs) = shift->lpuc('set_langs',@_);
    my @langs = $m->get_langs(lihs => $lihs);
    $m->ustop('no langs found') if !@langs;
    my %langp = ();
    $m->setplst(langs => \@langs, lihs => $lihs);
    $langp{$_} = 1 for @langs;
    $m->setphac(langp => \%langp, lihs => $lihs);
    $m->dpop($prog,@langs);
};

sub set_dok_langs {
    my ($m,$prog,$lihs,$dok,$dir,%opts) = shift->opuc('set_dok_langs',[[qw(nom_get)],[qw(dir_get)]],@_);
    my @langs = $m->set_langs($lihs) or $m->ustop('failed to set langs of dok %d in dir %D', d => $dok, D => $dir);
    # my $rewrite = $opts{rewrite};
    my $url = $m->setpvar(url => $m->dir2url) || $m->set_url;
    $m->put(mlhtdok => { dok => $dok }, doktmp=> 'now()', dokurl => $url); # TODO: insert only
    $m->set_topdoks;
    # $m->rewrite_subdoks if $rewrite;
    $m->fayl_predoks($dok, kmdfun => 'putdok') if $m->pvar('force');
    my @dokstyps = qw(subdoks grpdoks);
  DOKSTYPS: {
      my $dokstyp = shift @dokstyps;
      last unless $dokstyp;
      my @doks = $m->set_doks($dokstyp, dir => $dir);
      redo unless @doks;
      $m->putdoks($dokstyp, $dir, $dok, @doks);
      redo;
    };
    $m->dpop($prog,@langs);
};

=head3 Function dok_kre_kanal

Create channel: set up the current document as a news channel.
Argument 1 is the name of the channel to be created.
If this is '1', $m->pvar('dok') is used.  If it is '0' or empty, nothing is created.
The name of the channel is usually derived from the I<news_kanal> configuration option, but some cases, as in A2E::Mktdir, it is obtained from elsewhere.
The other elements of a channel record, which correspond to the C<news_kanalrem>, C<news_kanaldat> and C<news_supkanal> configuration variables, can also be supplied as commandline arguments.
The 

=cut
our %dokkanalp = ( 1 => 1, '*' => 1 );
sub dok_kre_kanal {
    my ($m,$prog,$lihs,$kanal) = shift->opuc('dok_kre_kanal',[qw(nom_let)], @_);
    my $dok = $m->pvar(dok => 1);
    $kanal = $dok if $dokkanalp{$kanal};
    return $m->dpop($prog) unless $kanal;
    my %vals = ();
    ($vals{kanalrem}, $vals{kanaldat}, $vals{supkanal}) = @_;
    $vals{kanalrem} ||= $m->{konfig}->news_kanalrem || $m->{prognom};
    $vals{kanaldat} ||= $m->{konfig}->news_kanaldat || $m->{konfig}->dokdatum;
    $vals{supkanal} ||= $m->{konfig}->news_supkanal;
  SUPKANAL_TEST: {
      last unless $vals{supkanal};
      my ($supkanal_ok) = $m->get_record('kanal', { kanal => $vals{supkanal} }, 'kanalrem');
      last if $supkanal_ok;
      $m->uwarn('omitting specification of inexistent parent news channel %k', k => $vals{supkanal});
      delete $vals{supkanal};
    };
    my $i = $m->put('kanal', { kanal => $kanal }, %vals) or $m->pstop('unable to edit record of news channel %k', k => $kanal);
    $m->dpop1($prog,$i);
};

=head3 Function dok_put_kanals

Insert the current file into one or more news/rss channels.
This routine is used by mktdir and dokdata2db.

=cut

sub dok_put_kanals {
    my ($m,$prog,$s,$dok) = shift->ppuc('dok_put_kanals',@_);
    my @putkanals = split m([\,\s]+), $s;
    $dok ||= $m->pvar(dok => 1);
    my $kadokrem = join ' ', $m->{prognom}, $m->timestamp;
    my $i = 0;
    foreach my $putkanal (@putkanals) {
	my ($kanal, $gravrank) = split m(\:), $putkanal;
	my %vals = (kadokrem => $kadokrem);
	$vals{gravrank} = $gravrank if defined $gravrank;
	$i += $m->put('kanaldok', { kanal => $kanal, dok => $dok }, %vals);
    };
    $m->dpop1($prog,$i);
};

=head3 Function dok2absurl

Take dok, return absolute url (beginning with 'http://')

Use dir2url if referring to current document, failing that derive from dok2url regex-replacement hash, failing that search database.
This was in A2E::Dokfs but moved here because of reliance on A2E::Tmplvars. file:/phm/18/10/26/sig/_lng.phm_pub_sig181026.txt::perl09

=head4 Subroutine rx_dok2absurl

Take dok, return absolute url derived from dok2url info such as in
file
    /adv/tmpl/a2e/lang_pre.txt
section dok2url

=cut

sub rx_dok2absurl ($$$;$) {
    my ($m,$prog,$lihs,$dok,$nom) = shift->lpuc('rx_dok2absurl',@_);
    $nom ||= 'dok2url_findrepl';
    my @dok2url_nomoi = $lihs->getlst($nom);
    return $m->dpop($prog) unless @dok2url_nomoi;
    my ($url, $var, $val, $find, $repl, $ok, @sems) = ();
  DOK2URL: {
      last if !@dok2url_nomoi;
      my $dok2url_nomo = shift @dok2url_nomoi;
      $var = $dok2url_nomo.'_find';
      $val = $lihs->getstr($var);
      do { $m->uwarn('find variable %v undefined', v => $var);next } if !$val;
      $find = $m->{sarb}->transform($val) or $m->ustop('can not obtain value for find variable %v', v => $var); # '(([a-z]+)\\_pub|eupat|apr|ius)'
      @sems = $dok =~ m(\A$find\Z); # ('oas_pub', 'oas')
    REPL: { # file:/phm/19/12/30/sig/_log22adv.phm_pub_sig191230.txt::768437
	last if !@sems;
	$var = $dok2url_nomo.'_repl'; # 'pub_repl'
	$repl = $lihs->getstr($var); # '$(or $(value ${1}_url),$(call puburl,${2}))'
	$m->ustop('can not obtain value for repl variable %v', v => $var) if !$repl;  
	$m->techo('applying repl %r on sems %S', r => $repl, S => \@sems);
	$url = $m->{sarb}->transform($repl, {}, @sems);
	$m->pstop('cant transform %r with sems %S to url', r => $repl, S => \@sems) unless $url;
	return $m->dpop($prog,$url,$dok2url_nomo);
      };
      $m->techo('nothing obtained applying find expression %f to document identifier %d', f => $find, d => $dok);
      redo DOK2URL;
    };
    $m->dpop($prog);
};

sub dok2absurl {
    my ($m,$prog,$lihs,$dok,%opts) = shift->opuc('dok2absurl',[qw(nom)],@_); # cannot use valid_dok here because circular
    my $url = '';
    my $nom = '';
  LOKAL: { # special case of deriving url from current location
      my $ok = $dok eq $m->pvar('dok') ? 1 : 0;
      last unless $ok;
      $url = $m->dir2url;
      return $m->dpop1($prog,$url);
    };
    $dok = $m->alidok($dok,lihs => $lihs);
    ($url,$nom) = $m->rx_dok2absurl($lihs,$dok);
  URL: {
      do { $m->techo('obtained url %u for dok %d using rx_dok2absurl with match rule %n', u => $url, d => $dok, n => $nom);last } if $url;
      $url = $m->db_dok2absurl($dok,%opts);
      do { $m->techo('obtained url %u for dok %d using db_dok2absurl', u => $url, d => $dok);last } if $url;
      ($url, $nom) = $m->rx_dok2absurl($lihs,$dok,'dok2url_findrepl_postdb');
      do { $m->techo('obtained url %u for dok %d using rx_dok2absurl using dok2url_findrepl_postdb with match rule %n', u => $url, d => $dok, n => $nom);last } if $url;
      $m->techo('failed to obtain an url for dok %d with dok2absurl', d => $dok);
    };
    $m->dpop1($prog,$url);
};
sub absurl { my $m = shift;$m->deprek_warn('absurl', 'dok2absurl', @_);return $m->dok2absurl(@_) }

=head3 Function ml_dok2absurl

Like dokurls but using predoks info to climb up the tree so as to find a more up-to-date or multilingual URL
Core part of dokdir.

=cut

sub ml_dok2absurl {
    my ($m,$prog,$lihs,$dok,$lang,$data,%opts) = shift->opuc('ml_dok2absurl',[[qw(nom_get)],['lang_get', 'data'],{ data => 'hacr_let' }],@_);
    $m->decho(nolangurl => d => $dok) unless $lang;
    my @predoks = $m->predoks($dok, typ_min => 3);
    my @subdirs = ();
  PREDOKS: { # first leaf is never processed but rather submited to absurl to provide basis for url
      last unless @predoks;
    TRAPROP: {
	last if !$lang;
	$data = $m->get_dokdata_cache_rek($dok, $lang);
	($data->{nom}) = $m->get_record('traprop', { dok => $dok, lang => $lang }, 'tranom'); 
      };
    DOKPROP: {
	last if $data->{nom};
      DIR: {
	  my $dir = $m->{dokprop}->{$dok}->{dir};
	  do { $m->pwarn(dirnodokprop => d => $dok);last } unless $dir;
	  $data->{nom} = basename $dir;
	}
	last if $data->{nom};
	($data->{nom}) = $m->get_record('dokprop', { dok => $dok }, 'doknom');
      }
      do { $m->uwarn(doknofol => d => $dok);last } unless $data->{nom};
      unshift @subdirs, $data->{nom};
      $dok = pop @predoks;
      redo;
    };
    $opts{lang} = $lang;
    my $absurl = $m->dok2absurl($dok, %opts) || '';
    return $m->Wpop0($prog, u => doknoabsurl => D => $dok) if !$absurl;
    $absurl = join '/', $absurl, @subdirs;
    $m->dpop1($prog,$absurl);
};

sub ml_dok2absdir {
    my ($m,$prog,$lihs,$dok,$lang,%opts) = shift->opuc('ml_dok2absdir',[[qw(dok)],[qw(lang_let)]],@_);
    $opts{lang} = $lang;
    my $url = $m->ml_dok2absurl($dok,%opts);
    my $dir = $m->url2dir($url,%opts);
    $m->dpop1($prog,$dir);
};

=head1 THE END

=cut

return 1;

# Local Variables:
# coding: utf-8
# mode: perl
# srcfile: "/adv/perl/A2E/Dokfs.pm.tmpl"
# End: