=head1 NAME
A2E::Tmplfil
=cut
package A2E::Tmplfil;
=head1 DESCRIPTION
Fill a template (based on the Perl Template Toolkit) with template
variables supplied in a syntax that supportes expansions known from
Makefiles written for GNU Make, read in from the commandline,
configuration files as well as (and mainly) makefile.
The syntax includes constructions like
NAME1 := fixed value with variable components, in nice ${color} coloring
FUNCTION1 = expandable value with parameters like ${1}, ${2} and ${3}
NAME2 := $(call FUNCTION1,a,b,c)
feast = let's feed the $(pl ${1}), $(pl ${2}) and other $(3 ${adj}) $(pl ${noun}) in ${locus}!
_my_feast = $(fill feast,cat,dog,$(2|call|italic),$(adj||lovely),$(pl|call|plural),$(noun||pet),$(locus||my house))
_your_feast = $(fill feast,tiger,crocodile,$(3|call|hyperref|${wildlife_url}),$(adj||wild),$(pl|call|plural),$(noun||beast),$(locus||your backyard))
plural = ${1}s
italic = ${1}
wildlife_url := http://en.wikipedia.org/wiki/Wildlife
hyperref = ${2}
include a2e/basic_template_variables.mk
include a2e/important_template_variables.mk?+
include a2e/unimportant_template_variables.mk?-
include_re /opt/a2e/share/hanzi/toTW.dict \A\"(\S+)\"\t\"(\S+)\"\Z
Supported make functions/directives include
call
shell
wildcard
foreach
ifdef
ifndef
ifeq
basename
notdir
include
export
unexport
Some of these are extended, e.g. ifeq matches regular expressions and it accepts more than one argument
Additional functions help separate the different layers of text so as to reduce the costs of multilinguality.
fill: insert variables and functions into texts
case: define a simple array
or: logical or
and: logical and
Find explanations with
perldoc A2E::SArb::Make(3)
Furthermore directives
include_re: include more vocabulary definitions using an alien syntax defined by a regex argument
ifeq: compare the first argument not only with a second one but with an unlimited list of further arguments, returning true if one matches
ifneq: negation of ifeq
ifgt, iflt, ifge, ifle: comparison functions greater_than, less_than, greater_or_equal, less_or_equal, working exactly like ifeq, i.e. returning true if comparison to any one of the subsequent arguments returns true
ifset: like ifdef but true only if value is non-null in Perl sense
ifnset: negation of ifset
ifeqs: similar ifeq but evaluates arguments as a variable and compares it with values provided in following case statements, e.g.
ifeqs styl
case dpat depat
include dpat_lang.txt
case |jpat.*|.*.ja.txt|
include jpat_lang.txt
case
include pat_lang.txt
endif
with possible multiple regexps in each case statement and possibility to choose separator
character by placing it at the beginning, e.g. '|' in this example, which prevents '.' from
being interpreted as separator character. ifeq works the same way, the use of ',' as
separator character is, unlike in GNU Make, not obligatory.
elif*: alternative (C) conditions can be specified; the if* loop ends after one of them was true
special: hook in external directives, e.g.
special = process bautext_tmpl.txt
special = debug 1 tmplini
special/non_debug/1/var:trivial
special = debug_sarb 0
special = miniverb u underline_verb
special = alias tmpl oas_tra oas_akt_aammdd
special = alias dok oal oas_akt1809
special = alias tmplang deplate multemp
special = miniverb c code_verb
special:progvars:sems2subflat:sems2subtmpl# leave these variables to the program, disallow any further modification by the user from here on
special|msg|the value of dd is %s but should be 01|${dd}|
special|error|the value of dd is %s but should be 01|${dd}|
special = antevars oas_varb_aamm tra,dd num # 'tra' and 'dd' must not be empty, 'num' may be empty
special = litvalid tit # validate lit tit based on contents of lits tit_valids, tit_prompt, lenmax_errmsg etc
special = setopt batch 1 # set a control variable stored in $m->{cache}
special,nonnull,dd
As shown in the examples, the argument is split by the first possible separator introduced by the user after the 'special' command.
New functions can be added by calling $m->{sarb}->add_renfun('name', sub { ... }), see A2E::SArb(3) and A2E::SArb::Make(3) for info.
Like in makefiles, there are two assignment statements, one with '=' for dynamic variables (i.e. functions), one with ':=' for static variables (strings).
Any dynamic variables that begin with '_' are expanded into static variables whose name does not have the initial '_' shortly before template processing begins; this is done by function render_dynaarbs.
The values of textchunks can represent multi-level list/hash structures, e.g.
special = dabarel person |person:person|person:sig|persnom:tit|persdes:des|lok|rol|perstyp|realpsn|pass|mail|status|
The first encountered separator character is taken to represent the next-lower level.
Hashes are lists grouped into groups of three cells of which the first is null, the second is a (simple) key and the third is a potentially complex value.
They are recognised by the duplication of the initial separator, e.g. '||' und thus must start with separators.
C commands that operate on hash strings are
special = defhac
special = hacputv
special = dabarel
C commands that operate on list strings are
special = deflst
special = seqpuc
special = tmplrels
special = tmpltoks
special = antevars
These commands parse the string into a tree using C, then perform an operation on that tree, and then again generate a string from that tree using C. Since the resulting string uses the separators from C according to the resulting structure's hierarchy, it will greatly differ from any string that the user would produce on his own by simple concatenation. Thus, when we treat strings as structures we prefer to use these commands.
By storing structures as strings we ensure that these structures can be transported in th SDBM database.
When a real list/hash reference is needed in a template, it can be produced on demand using the str2arb vmethod.
The 'include' syntax is like in Makefiles, with an INCLUDE_PATH that has Makefile-like defaults but can be changed via the tmplopts option.
This is a basic layer, on top of which other libraries like A2E::MLHT(3) and applications are built.
=head1 BUGS
Report to adv@a2e.de
=head1 VERSION
=over
=item 2010-04-20 version 0.2.0
Introduced groups and group-local definitions of string/list/hash variables.
=item 2010-03-29
Introduced str2arb, arb2str and their applications to support nexted list/hash structures represented as strings.
Certain kludgy mechanisms that were previously used, such as tmplhacs, will be abolished.
=item 2010-01-04 version 0.1.2
lots of changes and improvements.
introduced multidimensional hash variables as well as a few more 'special' verbs
=back
=cut
our $VERSION = '0.2.0';
=head1 LIMITATIONS
=head1 TODO
fix bugs, remove limitations
=head1 PREREQUISITES
=over
=item A2E::Prog(3)
=cut
use base 'A2E::TmplArb', 'A2E::Tmplkonf', 'A2E::Tmplvars';
use strict;use warnings 'all';no warnings 'uninitialized';
use File::Spec::Functions;
use List::MoreUtils qw(uniq);
use File::Basename;
use Scalar::Util qw(blessed);
use Data::Dumper;
=item Template(3)
=cut
$Template::BINMODE = ':utf8';use Template;
=item Template::Multilingual(3) etc
Use of these facilities, as well as of the A2E::Template::Plugin::MLHT plugin, is discontinued.
Instead the Make-like syntax with multilinguality supporting extensions provided by A2E::SArb::Make(3) should be used and extended.
Ultimately the set_template subroutine, which invokes various Template extensions, will probably be reduced to a simple invocation of Template.
=cut
use Text::Roman qw(roman);
use A2E::Template::Provider;
use A2E::Template::Context;
use A2E::Template::Directive;
use Template::Config;
use Template::Parser;
# $Template::Config::Provider = 'A2E::Template::Provider';
=item A2E::SArb::Make(3)
The workhorse of make-like macro expansion in lexical source files.
=cut
use A2E::SArb::Make;
use Encode qw(decode _utf8_on);
=back
=cut
our %MSGS = (
pseudokond => 'ignoring would-be conditional conjunction %c',
fprereq => 'file %f is already on the list of prerequisites, once is enough',
setvarargs => 'upon setvar %n failed to apply %k to %A: %e',
nofinklud => 'included file %f not found',
fginklud => 'pseudo-including file %f in group %g with semi-implemented include syntax',
nonnumsfx => 'numeral suffix %n is not numeral',
nodefnlst => 'no definition list variable in %n',
nonendef => 'endef is not ending any definition',
topanon => 'anonymous group can not occur at top level',
notmpl => 'current tmpl unknown',
tavarstv => 'antevars inapplicable for template %t: %v',
atmplvarv => '%a template variable %v',
matchnovar => 'unknown match object variable %n',
matchrnoval => 'unknown match regexp variable %n',
matchvnoval => 'unknown match transformation verb variable %n',
rnorx => 'unable to compile regexp from %r',
l2vnefin => 'unassigned values %v remaining in lst2vars assignment',
matchnefin => 'unassigned values %v remaining in match',
nnolst => 'unable to convert variable %n to list: %m',
nnolstv => 'unknown list variable %n',
nnoval => 'no value for variable %n',
nnovalv => 'unknown variable %n',
fginclude => 'including file %f in group %g',
ankvsnom => 'Anker %a deckt sich nicht mit Gruppennamen %n, Übergang in reine Org-Syntax?',
evalbad => 'Sorry, I am unable to gather any content or structure from this string: %t',
no_include_path => 'No include path where to search for file %f',
context_no_sarb => 'no context sarb defined',
bad_template => 'found bad template',
bad_template_opts => 'generated bad template with options %O',
new_template => 'unable to set template with options %O',
exofls => 'in file %f line %l: %s',
errflm => 'error in file %f line %l: %m',
fgeof => 'encountering end of file %f inside group %g',
gnehacr => 'local variable container %n is not a hashref',
nogvar => 'no local %g variable defined for %n in %l',
badref => 'reference variable %n should be of type %t but is of type %r',
nofbinpath => 'no file %b found in path %P',
invexpfl => 'invalid include expression in file %f at line %l: %e',
inkludfdko => 'included file %f not found in include path directories %D',
inkludko => 'failed to include %i in %f at line %l: %m',
frmnom => 'looking for possible default format info @%f',
nogrupvar => 'no grup to search variable %n in',
finkloz => 'final content directive %n must be followed by closing bracket',
notgrupopen => 'This line looks like but is not a group opening bracket: (%l%k',
gnopars => 'nothing to parse for string %s in textchunk %n with attributes %l',
nogruplini => 'gruplini without a group',
litnom_p => 'user given identifiers like %k must never begin or end in _',
setnusekt => 'attempting to make unnamed section the current one: %l',
nusekt => 'attempting to store unnamed section as %n: %l',
folinnfols => 'fol %f already in fols %F of %n',
nolits => 'no lits variable available for internal variable %n with value %v',
supnofols => 'upper node %s exists but has no __fols to push onto',
badfrmer => 'invalid frmer %r in frml %t',
glingruperef => 'in %n.glingrup __frm is an empty array reference',
novarfrml => 'in %g.varfrm unknown formatter variable %f found in expression %e',
nolstvarfrml => 'in %g.varfrm unknown formatter list variable %f found in expression %e',
valfrmlexp => 'invalid format array expression %e',
varfrmlarf => 'in %n.varfrm formatter variable %f has as value an invalid array expression %e',
varfrmlnul => 'in %n.varfrm formatter variable %f given by expression %e refers to an empty array',
frmlok => 'OK on frml %f',
frmlnoref => 'in %n.glingrup __frm %f is not an array reference',
gnofrml => 'no formatter found for group %g, not even default info @frm is available',
nofrml => 'no formatter info given for document node %n',
efrml => 'in %n empty formatter array reference frml %f',
nfrml => 'in %n invalid formatter array reference frml %f',
frml => 'in %n.subgrups unknown formatter array reference frml',
nomlits => 'invalid property table of %n: %l',
nomcirkl => 'You were about to open superior node %n once more and thus create an endless loop of nodes.',
litudz => 'user-given text identifiers like %k must never end in number and underscore',
lituaz => 'user-given identifiers like %k must never begin or end with an underscore',
noreahac => 'not reassigning hash %n to %v',
norealst => 'not reassigning list %n to %v',
noovwra => 'ignoring attempt to overwrite antevars variable %n whose value is %v with new value %w',
noovwrp => 'ignoring attempt to overwrite progvars variable %n whose value is %v with new value %w',
sektnomnil => 'unnamed section at top level',
nolitsfols => '__fols list not found at all, not even an empty one',
regrup => 'about to open a group whose name %n already has a value %f' );
=head3 $arg = $m->valid_\w+($lihs,$arg,$vahr): validators
for use with A2E::TmplArb vlpuc, opuc, vopuc via $m->{var2validp}
=cut
sub valid_verb2fun {
my ($m,$lihs,$verb) = @_;
$m->pstop('attempting to retrieve special directive with invalid name %v', v => $verb) if $verb !~ m(\A\w+\Z);
my $fun = $m->{tmplfil_special}->{$verb};
$m->pstop('retrieved an invalid special directive %f for name %v', v => $verb, f => $fun) unless 'CODE' eq ref $fun;
$fun;
}
=head4 $lstr = $m->valid_x2lstr($lihs,$elm): Coerce element or listref into listref
Return a listref in any case, similar to elm2list but for use in validators.
=cut
sub valid_x2lstr {
my ($m,$lihs,$elm) = @_;
my @list = $m->elm2list($elm);
\@list;
}
=head3 $ok = $m->tmplfil_defvars($lihs): initiate package A2E::Tmplfil
=cut
sub tmplfil_defvars {
my ($m,$prog,$lihs) = shift->qlpuc('tmplfil_defvars',@_) or return;
$m->tmplkonf_defvars($lihs);
$m->tmplvars_defvars($lihs);
$m->{var2validp}->{verb2fun} = \&valid_verb2fun;
$m->{var2validp}->{x2lstr} = \&valid_x2lstr;
my $verbose = $m->{cache}->{verbose} || '0';
# 以下為實驗性、目前不始用 hacs, lsts, 見 file:/sig/oas/19/06/adv/_lng.oas_adv1906.txt::jung
=head1 OPTIONS
=head1 Object Variables
Some of these are used by upper libraries
=over
=item INTERFACE hashref tmplarbs
store for pre-compiled (tree-formed) template functions, passed to A2E::SArb object $m->{sarb} and used in there, especially by &A2E::SArb::getarb
=cut
$m->{tmplarbs} = {};
=item hashrefs tmplhacs, tmpllsts
Cache for pre-compiled structured textchunks created with defhac and deflst respectively.
These variables can only be modified with special commands, all of which leave the current tree representation in the cache.
When variable values are not read from makefile source but from the dbm database, the cache records are created by the first invocation and reused thereafter.
=cut
=item lits: properties of the current group
Property tables of the current and other groups are stored in nom2lits.
=cut
$m->{lits} = { __lvl => 0 };
=item nom2lits: table of groups
Table of tables of properties of groups, one for the absolute name of each textchunk variable that has group properties.
=cut
$m->{nom2lits} = { };
=item hashref tmplxarbs
Cache for final variables generated with nom2xarbs, where the maketext references are stored by perl references.
This complicates programming: any function (such as defarb, lstpuc*, hacput*) that resets a structured value must delete its entry in tmplxarbs.
=cut
$m->{tmplxarbs} = {};
=item tmplfuns
Store for ?additional? internal parsing functions, passed to A2E::SArb object $m->{sarb}, currently not used much.
=cut
$m->{tmplfuns} = {};
=item hashref setvar_hooks
setvar_hooks = hashref((varnom, listref(opts, kmdverb, kmdarg*)))
Indexed by the name of the variable upon whose setting a command is executed.
Each command consists of an options hashref, the special command verb and any initial argument.
These are registered by the special C and C directives.
=cut
$m->{setvar_hooks} = {};
=item Conditional directives
=back
=item iflevel*
info stores for keeping track of conditional statements in textchunk files
=over
=item m_iflevel
current conditional level
=cut
$m->{iflevel} = 0;
=item iflevel_komp
hash of values to which condition arguments are to be compared at each condition level
=cut
$m->{iflevel_komp} = {};
=item iflevel_vals
hash of ternary values to which the last condition at each condition level evaluated.
1: true
0: false
-1: no longer to be evaluated, e.g. because a previous condition was already true.
=cut
$m->{iflevel_vals} = {};
=back
=head1 OPTIONS
The options of the prerequisite library A2E::Prog(3) are also available here.
=over
=item --tmplvars|--tv I=I
set a template variable
=cut
$m->konfig_define(['tmplvars','tv'],'s%');
=item --tmplvars_string|--ts key1=val1,key2=val2,...
comma-separated list of template variable assignments in one argument
=cut
$m->konfig_define(['tmplvars_string','ts'],'s');
=item --tmplvars_fayls|--tf I
read variables from I, where they are defined in Makefile-like syntax
=cut
$m->konfig_define(['tmplvars_fayls','tf'],'@');
=item --setnomval '\A((?:export|unexport)\s+)?([@%]?\w+)\s+([?]?)([\-\+]?\:?)\=[\-\+]?\s+(.*)\s*\Z'
regular expression used for recognising assignment statements of all types. Should resolve to
$1 : 'export', 'unexport' or ''
$2 : variable name
$3 : '?' or null
$4 : ':' or null
$5 : variable value
=cut
$m->qre_define('setnomval', 's', '\A((?:export|unexport)\s+)?([@%]?[a-zA-Z][\w\.]*)\s+([?]?)([+-]?)([:]?)\=\s*(.*)\Z');
$m->konfig_define('tabseps', '@', [ '|', '&' ]);
$m->konfig_define('lvalnomp','s%', { tit => 1, sut => 1, des => 1, lab => 1 });
=head1 CONFIGURATION FILE
The
/etc/opt/a2e/tmplfil.konf
~/tmplfil.konf
@tmplfil
are read. Moreover configuration files of the prerequisite libraries are inherited.
=cut
$m->konfayl('tmplfil.konf');
=head1 MESSAGES
Translatable messages to be exported from variable %MSGS
=cut
$m->prog_msgdefs('tmplfil',%MSGS); #PROGDEFS
$m->qpop1($prog,1);
};
=head1 IMPLEMENTATION
=head2 Overwritable Functions
The bulk of each function is forked out into a non-overwritable variant used for mix-in applications such as mlht(1)
=head3 Function defvars and forkout tmplfil_defvars
=cut
sub defvars {
my ($m,$prog,$lihs) = shift->qlpuc('A2E::Tmplfil::defvars', @_) or return;
$m->SUPER::defvars($lihs);
$m->tmplfil_defvars($lihs);
$m->qpop1($prog,1);
};
=head4 ogpuc/tgpuc: extension of A2E::TmplArbs:opuc/tpuc for insering $gvars into arguments and %opts
Usage is like opuc/tpuc except that an additional $gvars hashref is inserted just before the regular arguments begin i.e. after $lihs/$optsr
=cut
sub ogpuc {
my ($m,$prog,$lihs,$argsr,%opts) = shift->opuc0(@_);
$opts{gvars} ||= $m->{grupvars};
($m,$prog,$lihs,$opts{gvars},@$argsr,%opts);
};
sub tgpuc {
my ($m,$prog,$lihs,$optsr,@args) = shift->tpuc(@_);
$optsr->{gvars} ||= $m->{grupvars};
($m,$prog,$lihs,$optsr,$optsr->{gvars},@args);
}
=head4 Function arb2xarb
Recursively expand the stored structure representation of a textchunk, such that any %hash, @list and $scalar references contained therein are replaced by references internally.
The thus expanded variable is not suitable for storage in the tmplhacs/tmplist caches and can not be converted back to its flattened string for storage in the tmplvars cache, but it can be used for internal operations.
Thus, the nom2xhac and nom2xlst functions use arb2xarb as a final expansion step in those variables that have been defined as expandable with defxhac, defxlst or the like.
args := arb
rets := xarb
=cut
sub strval_defarb { # former var2arb
my ($m,$prog,$lihs,$typ,$nom,$lstr,%opts) = shift->lpuc('strval_defarb',@_);
my ($str,$lvlmax) = eval { $m->str2str8lvlmax($lstr) };
$m->pstop('cant set %n to %v: %s', n => $nom, v => $lstr, s => $@) if $@;
my $arb = $m->defarb($lihs,$typ,$nom,$str,$lvlmax,%opts);
$m->dpop1($prog,$arb);
}
sub arb2xarb {
my ($m,$prog,$arb,$lihs) = shift->ppuc('arb2xarb',@_);$lihs = $m->get_lihs($lihs);
my $ref = ref $arb;
my $xarb;
REF: {
do { $xarb = {};$xarb->{'_keys_'} = $arb->{'_keys_'};foreach my $nom (@{$arb->{'_keys_'}}) { $xarb->{$nom} = $m->arb2xarb($arb->{$nom},$lihs) };last } if 'HASH' eq $ref;
do { $xarb = [];foreach my $elm (@$arb) { push @$xarb, $m->arb2xarb($elm,$lihs) };last } if 'ARRAY' eq $ref;
my ($pfx, $nom) = $arb =~ m(\A([\%\@\$])(\w+)\Z);
do { $xarb = $arb;last } unless $nom;
PFX: {
do { $xarb = $m->nom2hac($nom,$lihs);$m->ustop('hashvar %n not defined', n => $nom) unless $xarb;last } if $pfx eq '%';
do { $xarb = $m->nom2lst($nom,$lihs);$m->ustop('listvar %n not defined, %s', n => $nom) unless $xarb;last } if $pfx eq '@';
do { $xarb = $lihs->getstr($nom);$m->ustop('stringvar %n not defined', n => $nom) unless $xarb;last } if $pfx eq '$';
$m->pstop('failed to parse %A in xarb', A => $arb);
};
last if $m->non_dynavar_p($nom);
$xarb = $m->arb2xarb($xarb,$lihs);
};
$m->dpop1($prog,$xarb);
};
=head3 Functions nom2hac, nom2lst, nom2xhac, nom2xlst
The normal way of invoking the unflattened value of a hash/list textchunk.
Take the variable from the tmplhacs cache if possible, otherwise (i.e. when using dbm files) store it there.
Ensure that a real hash/list reference is returned, fail otherwise.
args := nom
nom :: name of a hash/list variable
nom => 'dabarels'
rets := arb
arb :: reference to the internal representation of the variable
defhac:arb => { traprop => [ ... ], ... }
deflst:arb => [ 'traprop', 'spez' ]
While the C and C functions serve as subroutines for other functions within Tmplfil.pm, the C functions are used externally, especially in invoking libraries such as A2E::Dokfs, A2E::MLHT, A2E::Mktdir and even, via a vmethod definition in A2E::MLHT, in TT Templates, where they make structured structured maketext variables available for Template processing, e.g. in nested iterations.
=cut
sub __nom2arb__ ($$$$$;$) {
my $m = shift;
my $prog = shift;
my $typ = shift;
my $xpand = shift;
$m->dpuc($prog, @_);
my $nom = shift;
$m->pstop('invalid nom %n', n => $nom) if ref $nom;
my $lihs = $m->get_lihs(shift);
my $treg = $lihs->treg($typ);
my $arb = $lihs->{$treg}->{$nom};
my $tref = $lihs->tref($typ);
my $str = '';
GET_ARB: {
last if $arb;
$str = $lihs->getstr($nom);
$m->ustop('no such textchunk %n', n => $nom) if ! $str;
$arb = $m->str2arb($str);
if ($arb) {
$m->ustop('%n is not a %t variable', n => $nom, t => $tref) unless $tref eq ref $arb;
} else {
$arb = 'HASH' eq $tref ? {} : [];
};
};
$lihs->{$treg}->{$nom} = $arb;
my $nondyn = 0;
XARB: {
last unless $xpand;
$nondyn = $m->non_dynavar_p($nom);
last if $nondyn;
$arb = $m->{tmplxarbs}->{$nom} || $m->arb2xarb($arb,$lihs);
$m->{tmplxarbs}->{$nom} = $arb;
};
$m->dpop1($prog,$arb);
};
sub nom2hac ($$;$) {
my ($m,$nom,$lihs) = @_;
$m->__nom2arb__('nom2hac', '%', 0, $nom, $lihs);
}
sub nom2lst ($$;$) {
my ($m,$nom,$lihs) = @_;
$m->__nom2arb__('nom2lst', '@', 0, $nom, $lihs);
}
sub nom2xhac ($$;$) {
my ($m,$nom,$lihs) = @_;
$m->__nom2arb__('nom2xhac', '%', 1, $nom, $lihs);
}
sub nom2xlst ($$;$) {
my ($m,$nom,$lihs) = @_;
$m->__nom2arb__('nom2xlst', '@', 1, $nom, $lihs);
}
=head3 Functions seqpucq, seqpucv, seqpuch, seqpucl, seqpucs, lstpucq, lstpucv, lstpuch, lstpucl, lstpucs
arg1 $listnom: name of a list-like textchunk
arg2 $nurnov: whether to push a member only if it is new i.e. not yet in the list
args3ff @noms: members to push
This is the basis of some 'special' commands like tmplrels and tmpltoks.
Variables:
$lstnom: name of list, e.g. 'tmplrels'
$lststr: current string representation of list, e.g. '|sdenom|sdedes|'
$lstarb: tree representation of $lststr: [ 'sdenom', 'sdedes' ]
@elmstrs: elements to be added, in string representation, e.g. 'traprop'
$elmstr: one of @elmstrs
$elmarb: tree representation of $elmstr
Parameters:
nurnov :: new only, refuse and warn about duplicates; check is only performed on string values including references
eval_p :: evaluate the new member with str2arb and try to turn it into a structure, otherwise quote it verbatim
The C versions do not refuse duplicates.
Those that refuse duplicates are called C because a list without duplicates represents a sequence.
The final letters q (quoted), v (value), h (hashref), l (listref), s (stringref) have the same meaning and effects as in the hacput* functions.
=cut
sub __lstpuc__ ($$$$$@) {
my $m = shift;
my $prog = shift || '__lstpuc__';
my $nurnov = shift;
my $eval_p = shift;
$m->dpuc($prog);
my %opts = $m->ref2hash(shift);
my $lihs = $m->get_lihs($opts{lihs});
my $seplr = $opts{arbseps};
my $nom = shift;
$m->ustop('%n is not known as a list, use special deflst to define it', n => $nom) unless defined $lihs->{lsts}->{$nom};
my $lst = $m->nom2lst($nom);
my @strs = @_;
MEMBER: foreach my $str (@strs) {
my $arb = $eval_p ? $m->str2arb($str) : $str;
NURNOV: {
last if ref $arb;
last unless grep { $_ eq $arb } @$lst;
$m->uwarn('request to add duplicate member %a to list %n is %(SW|granted|refused).', a => $arb, n => $nom, SW => $nurnov);
next MEMBER if $nurnov;
};
push @$lst, $arb;
};
$lihs->{lsts}->{$nom} = $lst;
delete $m->{tmplxarbs}->{$nom};
my ($str,$lvlmax) = $m->arb2strl($lst,$seplr);
$lvlmax ||= $lihs->{lvlmax}->{$nom};
my $litstag = $m->pvar('litstag');
$lihs->putstr($nom => $str, lvlmax => $lvlmax, litstag => $litstag, typ => 'd');
$m->dpop1($prog,$str);
};
sub seqpucq {
my ($m, $prog, $lihs, $nom, $val, %opts) = shift->opuc('seqpucq',2,@_);my @vals = $m->elm2list($val);
my $str = $m->__lstpuc__($prog, 1, 0, \%opts, $nom, @vals);
$m->dpop1($prog,$str);
};
sub seqpucv ($$$%) {
my ($m, $prog, $lihs, $nom, $val, %opts) = shift->opuc('seqpucv',2,@_);my @vals = $m->elm2list($val);
my $str = $m->__lstpuc__('seqpucv', 1, 1, \%opts, $nom, @vals);
$m->dpop1($prog,$str);
};
sub lstpucq ($$$%) {
my ($m, $prog, $lihs, $nom, $val, %opts) = shift->opuc('lstpucq',2,@_);my @vals = $m->elm2list($val);
my $str = $m->__lstpuc__($prog, 0, 0, \%opts, $nom, @vals);
$m->dpop1($prog,$str);
};
sub lstpucv ($$$%) {
my ($m, $prog, $lihs, $nom, $val, %opts) = shift->opuc('lstpucv',2,@_);my @vals = $m->elm2list($val);
my $str = $m->__lstpuc__($prog, 0, 1, \%opts, $nom, @vals);
$m->dpop1($prog,$str);
};
sub __lstpucx__ {
my $m = shift;
my $prog = shift; # 'seqpucl'
my $pfx = shift; # '@'
my $treg = shift; # 'lsts'
my $typ = shift; # 'list'
my $nurnov = shift; # 1
$m->dpuc($prog, @_);
my %opts = $m->ref2hash(shift); # (lihs => $lihs, arbseps => ['|','+'])
my $lihs = $m->get_lihs($opts{lihs});
my $arbnom = shift; # '__dabarels__'
$m->pstop('%n is not a dynamic variable', n => $arbnom, t => $typ) if $m->non_dynavar_p($arbnom);
my @varnoms = ();
foreach my $varnom (@_) {
$m->pstop('%n is not known as a variable of type %t', n => $varnom, t => $typ) unless $lihs->{$treg}->{$varnom};
push @varnoms, $pfx . $varnom;
};
my $str = $m->__lstpuc__('',$nurnov,0,\%opts,$arbnom,@varnoms);
$m->dpop1($prog,$str);
};
sub seqpuch {
my ($m, $prog, $lihs, $nom, $val, %opts) = shift->opuc('seqpuch',2,@_);
$m->dpop1($prog,$m->__lstpucx__($prog, '%', 'hacs', 'hash', 1, \%opts, $nom, $val));
};
sub seqpucl {
my ($m, $prog, $lihs, $nom, $val, %opts) = shift->opuc('seqpucl',2,@_);
$m->dpop1($prog,$m->__lstpucx__($prog, '@', 'lsts', 'list', 1, \%opts, $nom, $val));
};
sub seqpucs {
my ($m, $prog, $lihs, $nom, $val, %opts) = shift->opuc('seqpucs',2,@_);
$m->dpop1($prog,$m->__lstpucx__('seqpucs', '$', 'vars', 'string', 1, \%opts, $nom, $val));
};
sub lstpuch {
my ($m, $prog, $lihs, $nom, $val, %opts) = shift->opuc('lstpuch',2,@_);
$m->dpop1($prog,$m->__lstpucx__($prog, '%', 'hacs', 'hash', 0, \%opts, $nom, $val));
};
sub lstpucl {
my ($m, $prog, $lihs, $nom, $val, %opts) = shift->opuc('lstpucl',2,@_);
$m->dpop1($prog,$m->__lstpucx__($prog, '@', 'lsts', 'list', 0, \%opts, $nom, $val));
};
sub lstpucs {
my ($m, $prog, $lihs, $nom, $val, %opts) = shift->opuc('lstpucs',2,@_);
$m->dpop1($prog,$m->__lstpucx__('lstpucs', '$', 'tmplvars', 'string', 0, \%opts, $nom, $val));
};
=head3 Functions hacputq, hacputv, hacputh, hacputl, hacputs
Set an element of a hash-like textchunk.
Invocation examples (of the corresponding C directives):
special = hacputq:progs:hello_world:Hello, my dear World!
special = hacputv kolumn_lists spez spez,person,datum
special = deflst spez_list spez,person,datum
special = hacputl kolumn_lists spez spez_list
special = hacputv kolumn_maps spez ||spez|transaction||person|user||datum|date|
special = defhac spez_hash ||spez|transaction||person|user||datum|date|
special = hacputh kolumn_maps spez spez_hash
spez_name = transaction
special = hacputs kolumn_names spez spez_name
EBNF:
args := hacnom, nom, val
hacnom :: name of a hash variable
nom :: hash key
val :: hash value
hacputq.val => 'Hello, my dear World!'
hacputq.val :: string which is literally inserted into the $hacnom hash as value of $nom
hacputv.val => '||a|1||b|2|'
hacputv.val :: string which is parsed with str2arb and inserted as a tree structure (arb := hac || lst) if one is found
hacputh.val => 'spez_hash'
hacputh.val :: name of a hash defined with defhac or equivalent
hacputl.val => 'spez_list'
hacputl.val :: name of a list defined with deflst or equivalent
hacputs.val :: 'spez_name'
hacputs.val :: name of a string variable defined by ordinary textchunk assignment or equivalent
The last three variants hacputh, hacputl and hacputs build a hash that references another variable and thus, when represented as a string, contains the reference whose type is indicated by a perlish special prefix C<%>, C<@> or C<$> as in
%spez_hash
@spez_list
$spez_name
The structure stored in the tmplhacs/tmpllsts cache also contains these references written in the same way.
Expansion of these references takes place directly before use by the arb2xarb via the nom2xhac and nom2xlst functions, provided that the structured variable was defined as dynamic with defxhac or the like.
=cut
sub __hacput__ {
my $m = shift;
my $prog = shift;
my $eval_p = shift;
$m->dpuc($prog, @_);
my %opts = $m->ref2hash(shift);
my $lihs = $m->get_lihs($opts{lihs});
my $seplr = $opts{arbseps};
my $hacnom = shift;
$m->pstop('%n not known as hash, use defhac to register', n => $hacnom) unless $lihs->{hacs}->{$hacnom};
my $hacarb = $m->nom2hac($hacnom);
my @keys = @{$hacarb->{_keys_}};
my %keysr = ();$keysr{$_} = 1 for @keys;
while ($#_ > 0) {
my $nom = shift;
$m->ustop('hash index must be a string, not %n', n => $nom) if ref $nom;
$m->vecho('hash index should be a symbol name, not %n', n => $nom) unless $nom =~ m(\A\w+\Z);
my $val = shift;
$val = $eval_p ? $m->str2arb($val) : $val;
$hacarb->{$nom} = $val;
do { $m->vecho('In hash %h overwritten old value of key %k', h => $hacnom, k => $nom);next } if $keysr{$nom};
push @keys, $nom;
$keysr{$nom} = 1;
};
@{$hacarb->{_keys_}} = @keys;
$lihs->{hacs}->{$hacnom} = $hacarb;
delete $m->{tmplxarbs}->{$hacnom};
my ($hacstr,$lvlmax) = $m->arb2strl($hacarb,$seplr);
my $litstag = $m->pvar('litstag');
$lihs->putstr($hacnom => $hacstr, lvlmax => $lvlmax, litstag => $litstag, typ => 'd');
$m->dpop1($prog, $hacstr);
};
sub hacputq { # literally quoted argument
my ($m,$prog,$lihs,$hac,$k,$v,%opts) = shift->opuc('hacputq',3,@_);
$m->dpop1($prog,$m->__hacput__($prog, 0, \%opts, $hac, $k, $v));
};
sub hacputv { # evaluated argument
my ($m,$prog,$lihs,$hac,$k,$v,%opts) = shift->opuc('hacputv',3,@_);
$m->dpop1($prog,$m->__hacput__($prog, 1, \%opts, $hac, $k, $v));
};
sub __hacputx__ {
my $m = shift;
my $prog = shift; # => 'hacputq'
my $tpfx = shift; # => '@'
my $treg = shift; # => 'lsts'
my $type = shift; # 'english type name for messages' => 'list'
$m->dpuc($prog, @_);
my %opts = $m->ref2hash(shift); # (lihs => $lihs, arbseps => ['|', '+'])
my $lihs = $m->get_lihs($opts{lihs});$opts{lihs} = $lihs;
my $arbnom = shift; # => '__dabarel__'
$m->pstop('%n is not a dynamic (type %t) variable', n => $arbnom, t => $type) if $m->non_dynavar_p($arbnom);
my $nom = shift; # => 'tab'
$m->pstop('%n is not a valid hash index name', n => $nom) unless $nom =~ m(\A\w+\Z);
my $valnom = shift; # => '_dbr_spez_' || '+padr+person+adr+tel+url+'
$m->pstop('%n is not known as a %t variable', n => $valnom, t => $type) unless $m->{lihs}->{$treg}->{$valnom};
my $str = $m->hacputq($arbnom, $nom, $tpfx . $valnom, %opts);
$m->dpop1($prog,$str);
};
sub hacputh {
my ($m, $prog, $lihs, $hac, $k, $v, %opts) = shift->opuc('hacputh',3,@_);
$m->__hacputx__($prog, '%', 'hacs', 'hash', \%opts, $hac, $k, $v);
};
sub hacputl {
my ($m, $prog, $lihs, $hac, $k, $v, %opts) = shift->opuc('hacputl',3,@_);
$m->__hacputx__($prog, '@', 'lsts', 'list', \%opts, $hac, $k, $v);
};
sub hacputs {
my ($m, $prog, $lihs, $hac, $k, $v, %opts) = shift->opuc('hacputs',3,@_);
$m->__hacputx__($prog, '$', 'vars', 'string', \%opts, $hac, $k, $v);
};
=head3 $ok = $m->dabarel($nom,$val,%opts{arbseps,lihs}): register a database relation
nom :: 'person'
val :: '|person+person|persnom+tit|persdes+L1|lok|rol|perstyp+typ|realpsn+real|pass|mail|status|'
opts.arbseps :: ['+','|']
The registered dabarel can then be connected to a document e.g. via tmplrels.
Store database relation info in the C<__dabarels__> hash.
To be used in maketext files by C directive.
=cut
sub dabarel {
my ($m,$prog,$lihs,$nom,$val,$seplr,%opts) = shift->opuc('dabarel',[[qw(nom text)],[qw(arbseps)],{ arbseps => 'lstr_let' }],@_);
my $lstnom = '_'.'dbr'.'_'.$nom.'_';
my @arbseps = eval { @$seplr };
$m->pstop('bad arbseps option %a: %m', a => $seplr, m => $@) if $@;
@arbseps = @{A2E::TmplArb::arbseps} unless @arbseps;
$m->pstop('no arbseps available at all') unless @arbseps;
$m->setlst($lstnom,$val,$lihs,\@arbseps);
# $opts{arbseps} = $seplr if 'ARRAY' eq ref $seplr; # file:/phm/21/09/09/sig/_lng.phm_pub_sig210909.txt::arbseps
# file:/phm/21/09/09/sig/_lng.phm_pub_sig210909.txt::arbseps
my $sep = shift @arbseps;
push @arbseps, $sep;
$opts{arbseps} = \@arbseps; # file:/phm/21/09/15/sig/_lng.phm_pub_sig210915.txt::arbseps
my $res = $m->hacputl('__dabarels__', $nom, $lstnom, %opts);
$m->dpop1($prog,$res);
};
=head3 $m->tmplrels(@rels)
Add one or more rels (database relation aka table name which has been defined with C) to _tmplrels_ (the list of dabarels to which document variables of the current template are written).
Check __dabarels__ (the internal hash in which all dabarels are registered) to ensure the added dabarel is valid.
=cut
sub tmplrels {
my ($m,$prog,$lihs,$rels) = shift->opuc('tmplrels',[qw(x2lstr)],@_);
foreach my $rel (@$rels) {
$m->ustop('relation %r not defined as dabarel', r => $rel) unless $lihs->{hacs}->{__dabarels__}->{$rel};
};
my $res = $m->seqpucq('_tmplrels_',$rels, lihs => $lihs);
$m->dpop1($prog,$res);
};
=head3 Function sektrek
Associate a section name with a database relation, allowing subsections of this section to be treated as database records when so indicated in reksekts.
=cut
sub sektrek {
my ($m,$prog,$lihs,$nom,$val,%opts) = shift->opuc('sektrek',[qw(nom text)],@_);
my $lstnom = '_'.'skt'.'_'.$nom.'_';
my $res = $m->setlst($lstnom, $val);
$m->dpop1($prog,$res);
}
=head3 Function reksekts
State which section names should be treated as data record groups.
This may appear in a document or a template definition.
=cut
sub reksekts {
my ($m,$prog,$lihs,$val,%opts) = shift->opuc('reksekts',1,@_);
my $res = $m->setlst('_reksekts_',$val);
$m->dpop1('reksekts', $res);
}
=head3 Function tmplfil_postkonfig
Here the work of reading makefiles into template variables is done. Any application that inherits this library will have the template variables read in, based on configuration and commandline options, before the main program starts.
=cut
sub make_sarbfun {
my ($m,$prog,$xnom,$xfun) = shift->ppuc('make_sarbfun',@_);
my $fsub = sub {
my $sarb = shift;$m->dpuc($xnom, @_);
my $vars = shift;
my $body = $sarb->render($vars, shift);
$body = &$xfun($m, $body);
return $m->dpop1($xnom,$body);
};
$m->dpop1($prog,$fsub);
}
sub sarb_addfun {
my ($m,$prog,$nom,$fun) = shift->ppuc('sarb_addfun',@_);
local $_ = $m->{sarb}->add_renfun($nom => $m->make_sarbfun($nom => $fun));
$m->dpop1($prog,$_);
}
sub tmplfil_lihs_initvars {
my ($m,$prog,$lihs) = shift->lpuc('tmplfil_lihs_initvars',@_);
# file:/phm/18/10/15/sig/_lng.phm_pub_sig181015.txt::mv_initvars
return $m->dpop($prog) if $lihs->{lsts}->{_tmplrels_};
$m->defxhac($lihs,'__dabarels__');
$m->deflst($lihs,'_antevars_' );
$m->deflst($lihs,'_tmpltoks_');
$m->deflst($lihs,'_reksekts_');
$m->deflst($lihs,'_tmplrels_');
$m->deflst($lihs,'include_extra');
$m->dpop1($prog,1);
};
sub lihs_initvars {
my ($m,$prog,$lihs) = shift->lpuc('A2E::Tmplfil::lihs_initvars',@_);
$m->tmplfil_lihs_initvars($lihs);
$m->dpop1($prog,1);
};
=head3 Functions lihs_new,lihs_old
Generate new A2E::Lihs object, restore previous one.
=head4 $ok = $m->tmplfil_postkonfig($lihs)
=head5 'special' commands and associated hash/list variables
=head5 special process
Process a TT Template
special process bautext_tmpl.txt
so as to make the block definitions found therein accessible for use from within maketext files:
I quote as follows: $(proc:quote:Arma virumque cano ....)
=head5 special process
Begin/end debugging here.
If optional block names are given, debug only those block, else everything.
args := flag, block*
flag := boolean
block :: a name of a block contained between dpuc and dpop statements
This works only if debugging is enabled -- which can be done by setting environment variable DEBUG_BLOKS to non-null.
=head5 special debug_sarb
begin/end debugging here.
args := flag, block+
flag := boolean
block :: a name of a block contained between dpuc and dpop statements
=head5 tmpltoks
List structure extension of document metadata to include multilingual variants of certain non-document data.
This relies on a given mechanism of meta-documentation in the database involving the tables flddes which references deffld which references deftab which references klesi (class of tables).
Given the preparation
a2e# insert into deffld values ( 'persnom', 'person', 't' ) ;
INSERT 185793 1
and /adv/tmpl/a2e/lang_pre.txt
special dabarel deprs |person:person|person:sde|persnom:sdenom|persdes:sdedes|lok:sdelok|rol:sderol|perstyp:sdetyp|realpsn:sdereal|pass:sdepass|mail:sdemail|status:sdesta|
something like
a2e# insert into flddes ( fld, lang, fldkey, fldval ) values ( 'persnom', 'zh', 'a2e', '亞通歐' ) ;
INSERT 185794 1
is done by the program when in _lng.*.zh.txt statements like
sde = a2e
sdenom = 亞通歐
are found.
Not implemented yet. (Really? pb150128: isn't it working in C?)
The idelits collection mechanism was supposed to make sure identifying lits/fields like sde/person are available when the data is to be written.
Not sure if it works at all as of 2017-01-29.
Some more reverse indexing needs to be done.
=head5 block debug_litnoms
store space-separated names given in environment variable DEBUG_LITNOMS into @{$m->{debug_litnoms}}
inform about values of these lits at various junctures in the program.
=cut
sub tmplfil_postkonfig {
my ($m,$prog,$lihs) = shift->qlpuc('tmplfil_postkonfig',@_) or return;
$m->tmplvars_postkonfig($lihs);
my $tmplopts = $m->{cache}->{tmplopts};
$tmplopts->{DEBUG} = $m->{DEBUG} ? 1 : 0;
$m->{tmplfil_special} ||= {};
$m->tmplfil_special_put(process => \&special_process);
$m->tmplfil_special_put(debug => \&special_debug);
$m->tmplfil_special_put(non_debug => sub { my $m = shift;$m->dpuc('special_non_debug', @_);my $flag = shift;$m->ustop('special directive non_debug invoked without initial 0/1 argument') unless $flag =~ m(\A[0,1]\Z);my @bloks = @_;if (@bloks) { foreach my $blok (@bloks) { $m->{non_debug_bloks}->{$blok} = $flag } };my $res = { flag => $flag, bloks => \@bloks };$m->dpop1('special_non_debug', $res) });
$m->tmplfil_special_put(upon_setvar => \&upon_setvar);
$m->tmplfil_special_put(upon_setvars => \&upon_setvars);
$lihs->{vars}->{$_} = $m->{konfig}->tmplvars->{$_} for keys %{$m->{konfig}->tmplvars};
TMPLVARS: {
my $s = $m->{konfig}->tmplvars_string;
last unless defined $s;
my @vars = split ',', $s;
my ($key, $val) = ();
foreach my $var (@vars) {
($key, $val) = split '=', $var;
$lihs->putstr($key => $val);
};
};
$m->{sarb}->{debug_bloks} = $m->{debug_bloks};
$m->tmplfil_special_put(debug_sarb => sub { my $m = shift;my $flag = shift;$m->ustop('special directive debug_sarb invoked without initial 0/1 argument') unless $flag =~ m(\A[0,1]\Z);my @bloks = @_;if (@bloks) { foreach my $blok (@bloks) { $m->{sarb}->{debug_bloks}->{$blok} = $flag } } else { $m->{sarb}->{DEBUG} = $flag };{ flag => $flag, bloks => \@bloks } } );
$m->tmplfil_special_put(non_debug_sarb => sub { my $m = shift;$m->dpuc('special_non_debug_sarb', @_);my $flag = shift;$m->ustop('special directive non_debug_sarb invoked without initial 0/1 argument') unless $flag =~ m(\A[0,1]\Z);my @bloks = @_;if (@bloks) { foreach my $blok (@bloks) { $m->{sarb}->{non_debug_bloks}->{$blok} = $flag } } else { $m->{sarb}->{nodebug} = $flag };my $res = { flag => $flag, bloks => \@bloks };$m->dpop1('special_non_debug_sarb', $res) });
$m->tmplfil_special_put(miniverb => sub { my $m = shift;return $m->{sarb}->miniverb_put(@_) });
$m->tmplfil_special_put(sfx2fun => sub { my $m = shift;my $lihs = $m->get_lihs;my $sup = $m->{lits}->{__nom};return unless $sup;@_ = map { $m->setvfol($_,$sup, lihs => $lihs) } @_;scalar @_ });
$m->tmplfil_special_put(jungils => sub { my $m = shift;
my $nom = $m->{lits}->{__nom};
$m->pstop('special jungils must be invoked from within a grup') unless $nom;
my $frmt = $m->grupopen_pars_frm(shift);
$m->grupopen_stor_frm($nom,$frmt);
return $frmt } );
$m->tmplfil_special_put(progvars => sub { my $m = shift;foreach my $var (@_) { $m->{progvars}->{$var} = $lihs->getarb($var) } });
$m->tmplfil_special_put(alias => sub { my ($m,$var,$alias,$real) = @_;$m->set_ali2val($var,$alias,$real) });
$m->tmplfil_special_put(echo => sub { my ($m,@args) = @_;$m->echo(1, map { $m->grupfill($_) } @args);scalar @args });
$m->tmplfil_special_put(error => sub { my $m = shift;$m->ustop(map { $m->grupfill($_) } @_) });
$m->tmplfil_special_put(nonnull => sub { my $m = shift;foreach my $nom (@_) { my $val = $lihs->getstr($nom);$m->ustop('variable %n must not be empty', n => $nom) unless $val };scalar @_ });
$m->tmplfil_special_put(begin => sub {
my ($m,@tags) = @_;my $lihs = $m->get_lihs;
my $flag = '__'. join '_', @tags;
$lihs->{vars}->{$flag} = 1;
1 } );
$m->tmplfil_special_put(end => sub {
my ($m,@tags) = @_;my $lihs = $m->get_lihs;
my $flag = '__'. join '_', @tags;
$lihs->{vars}->{$flag} = 0;
1 } );
$m->tmplfil_special_put(antevars => sub { my ($m,@args) = @_;$m->antevars(undef,@args) }) ;
$m->tmplfil_special_put(tmpl_antevars => sub { my ($m,@args) = @_;$m->tmpl_antevars(undef,@args) });
$m->tmplfil_special_put(deflst => sub { my ($m,$nom,$val) = @_;$m->deflst(undef,$nom,$val) });
$m->tmplfil_special_put(defhac => sub { my ($m,$nom,$val) = @_;$m->deflst(undef,$nom,$val) });
$m->tmplfil_special_put(setlst => sub { my ($m,$nom,$val) = @_;$m->setlst($nom,$val) });
$m->tmplfil_special_put(sethac => sub { my ($m,$nom,$val) = @_;$m->sethac($nom,$val) });
$m->tmplfil_special_put(setxlst => sub { my ($m,$nom,$val) = @_;$m->setxlst($nom,$val) });
$m->tmplfil_special_put(setxhac => sub { my ($m,$nom,$val) = @_;$m->setxhac($nom,$val) });
$m->tmplfil_special_put(defxlst => sub { my ($m,$nom,$val) = @_;$m->defxlst(undef,$nom,$val) });
$m->tmplfil_special_put(defxhac => sub { my ($m,$nom,$val) = @_;$m->defxhac(undef,$nom,$val) });
$m->tmplfil_special_put(seqpucq => sub { my ($m,$nom,@vals) = @_;$m->seqpucq($nom,\@vals) });
$m->tmplfil_special_put(seqpucv => sub { my ($m,$nom,@vals) = @_;$m->seqpucv($nom,\@vals) });
$m->tmplfil_special_put(seqpuch => sub { my ($m,$nom,@vals) = @_;$m->seqpuch($nom,\@vals) });
$m->tmplfil_special_put(seqpucl => sub { my ($m,$nom,@vals) = @_;$m->seqpucl($nom,\@vals) });
$m->tmplfil_special_put(seqpucs => sub { my ($m,$nom,@vals) = @_;$m->seqpucs($nom,\@vals) });
$m->tmplfil_special_put(lstpucq => sub { my ($m,$nom,@vals) = @_;$m->lstpucq($nom,\@vals) });
$m->tmplfil_special_put(lstpucv => sub { my ($m,$nom,@vals) = @_;$m->lstpucv($nom,\@vals) });
$m->tmplfil_special_put(lstpuch => sub { my ($m,$nom,@vals) = @_;$m->lstpuch($nom,\@vals) });
$m->tmplfil_special_put(lstpucl => sub { my ($m,$nom,@vals) = @_;$m->lstpucl($nom,\@vals) });
$m->tmplfil_special_put(lstpucs => sub { my ($m,$nom,@vals) = @_;$m->lstpucs($nom,\@vals) });
$m->tmplfil_special_put(hacputq => sub { my ($m,$nom,$k,$v) = @_;$m->hacputq($nom,$k,$v) });
$m->tmplfil_special_put(hacputv => sub { my ($m,$nom,$k,$v) = @_;$m->hacputv($nom,$k,$v) });
$m->tmplfil_special_put(hacputh => sub { my ($m,$nom,$k,$v) = @_;$m->hacputh($nom,$k,$v) });
$m->tmplfil_special_put(hacputl => sub { my ($m,$nom,$k,$v) = @_;$m->hacputl($nom,$k,$v) });
$m->tmplfil_special_put(hacputs => sub { my ($m,$nom,$k,$v) = @_;$m->hacputs($nom,$k,$v) });
$m->tmplfil_special_put(dabarel => sub { my ($m,$k,$v) = @_;$m->dabarel($k,$v) });
$m->tmplfil_special_put(sektrek => sub { my ($m,$k,$v) = @_;$m->sektrek($k,$v) });
$m->tmplfil_special_put(reksekts => sub { my ($m,$val) = @_;$m->reksekts($val) });
$m->tmplfil_special_put(tmplrels => sub { my ($m,$val) = @_;$m->tmplrels($val) });
$m->tmplfil_special_put(tmpltoks => sub { my ($m,@vals) = @_;$m->seqpucq('_tmpltoks_', \@vals) });
$m->tmplfil_special_put(setopt => sub { my $m = shift;$m->dpuc('setopt', @_);my $nom = shift;my $val = shift;$m->ustop('no such option %n', n => $nom) unless defined $m->{cache}->{$nom};$m->{cache}->{$nom} = $val;$m->dpop1('setopt', $val) });
$m->tmplfil_special_put(upon_setvar => sub { shift->upon_setvar(@_) });
$m->tmplfil_special_put(upon_setvars => sub { shift->upon_setvars(@_) });
$m->set_template_include_path unless $tmplopts->{INCLUDE_PATH};
$m->{tmplfil_kompopfuns} = { eq => sub { $_[0] eq $_[1] }, neq => sub { $_[0] ne $_[1] }, lt => sub { $_[0] < $_[1] }, gt => sub { $_[0] > $_[1] }, le => sub { $_[0] <= $_[1] }, ge => sub { $_[0] >= $_[1] } };$m->{tmplfin_kompopfuns}->{ne} = $m->{tmplfin_kompopfuns}->{neq};
$m->{kompar_match} = sub { my ($arg, $komp) = @_;$arg =~ m(\A$komp\Z) };
$m->{kompar_equal} = sub { my ($arg, $komp) = @_;$arg eq $komp };
my $render_match = sub {
# hodie = 2018-10-08
# datum_regex = \A(d{4})\-(\d{2})\-(\d{2})\Z
# match_ok = $(match|hodie|datum_regex|aaaa|mm|dd)
my $sarb = shift;
my $lihs = $sarb->{lihs};
my $vars = shift;
my $nom = $sarb->render($vars, shift);
local $_ = $lihs->getstr($nom) || $m->ustop(matchnovar => n => $nom);
$nom = $sarb->render($vars, shift);
my $srxp = $lihs->getstr($nom) || $m->ustop(matchrnoval => n => $nom);
my $rxp = qr($srxp) || $m->ustop(rnorx => r => $srxp);
my @vals = m($rxp);
my ($val);
my $litstag = $m->pvar('litstag');
while (@_) {
$nom = $sarb->render($vars,shift);
$val = shift @vals;
do { $m->uwarn(nnoval => n => $nom);last } unless $val;
$lihs->putstr($nom => $val, litstag => $litstag, typ => 'd');
};
do { $m->uwarn(matchnefin => v => $m->koniug_et(@vals));return } if @vals;
$m->arb2str(\@vals);
};
my $render_rxvok = sub {
# hodie = 2018-10-08
# datum_regex = \A(d{4})\-(\d{2})\-(\d{2})\Z
# datum_verb = '${1}年${2}月${3}日'
# DATUM := $(rxvok|datum_regex|datum_verb|${hodie})
# 前二者被視為動詞之延伸故為變量
my $sarb = shift;
my $lihs = $sarb->{lihs};
my $vars = shift;
my $nom = $sarb->render($vars, shift);
my $srx = $lihs->getstr($nom) or $m->ustop(matchrnoval => n => $nom);
my $qrx = qr($srx) or $m->ustop(rnorx => r => $srx);
$nom = $sarb->render($vars, shift);
my $vok = $lihs->getstr($nom) or $m->ustop(matchvnoval => n => $nom);
local $_ = $sarb->render($vars, shift);
my @vals = m($qrx);
return unless @vals;
my $val = $sarb->val_args_call($vok, $vars, @vals);
return $val;
};
my $render_lst2vars = sub {
# |lst2vars|amdl|aaaa|mm|dd|, where amdl is a name of an existing list variable, whose elements are then assigned to aaaa, mm and dd.
my $sarb = shift;
my $lihs = $sarb->{lihs};
my $vars = shift;
my $nom = $sarb->render($vars, shift);
my $val = $lihs->getstr($nom) || $m->ustop(nnovalv => n => $nom);
my $arb = $lihs->getlstr($nom) || $m->ustop(nnolstv => n => $nom);
my @vals = eval { @$arb };
$m->ustop(nnolst => n => $nom, m => $@) if $@;
my $litstag = $m->pvar(litstag => 1);
while (@_) {
$nom = $sarb->render($vars,shift);
$val = shift @vals;
do { $m->uwarn(nnoval => n => $nom);last } unless $val;
$lihs->putstr($nom => $val, litstag => $litstag, typ => 'd');
};
$m->uwarn(l2vnefin => v => $m->koniug_et(@vals));
return $m->arb2str($arb);
};
my $render_slv = sub {
my $sarb = shift;
my $lihs = $sarb->{lihs};
my $vars = shift;
my @slngs = $m->grupvars_getlst($lihs,'slngs');
my $lang = $m->pval(lang => 1);
my ($val,$lval) = ('','');
foreach my $lng (@slngs) {
$val = shift;
next unless $lng eq $lang;
$lval = $sarb->render($vars, $val);
last;
};
return $lval;
};
my $render_assoc = sub { # |assoc|fol|_antevars|
my $sarb = shift;
my $lihs = $sarb->{lihs};
my $vars = shift;
my $key = $sarb->render($vars, shift);
$m->ustop('invalid assoc key %k', k => $key) unless $key =~ m(\A\w+\Z);
my $var = $sarb->render($vars, shift);
my $val = $lihs->getstr($var);
$m->ustop('no such variable %v', v => $var) unless $val;
$val = $lihs->{hacs}->{$var} || $m->str2arb($val);
$m->ustop('no such hash variable %v', v => $var) unless 'HASH' eq ref $val;
$lihs->{hacs}->{$var} ||= $val;
$val->{$key} };
$m->{sarb}->add_renfun(match => $render_match);
$m->{sarb}->add_renfun(rxvok => $render_rxvok);
$m->{sarb}->add_renfun(slv => $render_slv);
$m->{sarb}->add_renfun(lst2vars => $render_lst2vars);
$m->sarb_addfun(slv => $render_slv);
$m->{sarb}->add_renfun(assoc => $render_assoc);
$m->sarb_addfun(romnum => \&romnum);
$m->sarb_addfun(num2alpha => \&num2alpha);
$m->sarb_addfun(num2Alpha => \&num2Alpha);
$m->riid_tmplvars_fayl($_) for @{$m->{konfig}->tmplvars_fayls};
DEBUG_LITNOMS: {
my $litnoms_s = $ENV{DEBUG_LITNOMS};
last unless $litnoms_s;
my @litnoms_l = split m(\s+), $litnoms_s;
last unless @litnoms_l;
$m->{debug_litnoms} = [ @litnoms_l ];
};
$m->{lihs} ||= $lihs;
$m->lihs_initvars($lihs); # still needed because get_lihs from lowest level may be used during bootstrapping
$lihs->setdir($m->get_cwd);
$m->qpop1($prog,1);
};
=head3 Special directive function upon_setvar
Register a hook, i.e. a commandline, including expandable maketext expressions, that will be executed after the variable is written.
args := varnom, kmdverb, *kmdarg
varnom :: name of variable on whose resetting the command will be executed
kmdverb :: special directive to invoke
*kmdarg :: arguments which will be maketext-evaluated and passed to kmdverb
rets := ok
ok :: If true, the hook will be removed, otherwise it will stay and a warning will be issued.
The use of this information happens in the C block of function C.
=cut
sub __upon_setvar__ {
my $m = shift;
my $fun = shift;
my $singul = shift;
$m->dpuc($fun, @_);
my $varnom = shift;
my $kmdverb = shift;
$m->pstop('%f %n: special directive %k not known', f => $fun, n => $varnom, k => $kmdverb) unless $m->{tmplfil_special}->{$kmdverb};
my @kmdargs = @_;
$m->{setvar_hooks}->{$varnom} ||= [];
push @{$m->{setvar_hooks}->{$varnom}}, [ { singul => $singul }, $kmdverb, @kmdargs ];
$m->dpop1($fun, $varnom);
};
sub upon_setvar {
return shift->__upon_setvar__('upon_setvar', 1, @_);
}
sub special_debug {
my $m = shift;
$m->dpuc('special_debug', @_);
my $flag = shift;
$m->ustop('special debug invoked without initial 0/1 argument') unless $flag =~ m(\A[0,1]\Z);
my @bloks = @_;
if (@bloks) { foreach my $blok (@bloks) { $m->{debug_bloks}->{$blok} = $flag } } else { $m->{DEBUG} = $flag };
my $res = { flag => $flag, bloks => \@bloks };
$m->dpop1('special_debug', $res);
};
sub special_process {
my $prog = 'special_process';my $m = shift;$m->dpuc($prog,@_);
my $block = shift;
my %params = @_;
$m->{template}->process($block, \%params);
$m->pstop($m->{template}->error()) if $@;
my $res = { block => $block, params => \%params };
$m->dpop1($prog,$res);
};
sub upon_setvars {
return shift->__upon_setvar__('upon_setvars', 0, @_);
}
=head3 $m->antevars(\@primnoms,@restnoms) => \@antevars
Arguments divided into one argument, consisting of a list of primnoms (primary names) which must be known and nonnull already, and the remaining arguments, restnoms, which are written into the configuration file antefayl0 even with null values
set antevars only if we are in the right template, i.e between a pair of
special begin tmpl $tmpl_name
special end tmpl $tmpl_name
where $tmpl_name is the current document's template.
=cut
sub antevars {
my ($m,$prog,$lihs,$primnomsr,@restnoms) = shift->lpuc('antevars',@_);my @primnoms = $m->textsep2list($primnomsr);
my $chk_noms = sub { # 190818 no longer usable since we have different $lihs objects
foreach my $nom (@primnoms) {
next unless $nom;
next if defined $lihs->getstr($nom);
$m->ustop(atmplvarv => a => do { if (not exists $lihs->{vars}->{$nom}) { 'inexistent' } elsif (not defined $m->{lihs}->{vars}->{$nom}) { 'undefined' } else { 'empty' } }, v => $nom ); # stop_atmplvarv
};
};
# &$chk_noms;
$m->uniqpush($lihs->{lsts}->{_antevars_},\@primnoms,\@restnoms);
$lihs->{hacs}->{_antevarp_}->{$_} = 1 for @{$lihs->{lsts}->{_antevars_}};
$m->dpop1($prog,$lihs->{lsts}->{_antevars_});
};
sub tmpl_antevars {
my ($m,$prog,$lihs,@args) = shift->lpuc('tmpl_antevars',@_);
my $tmpl = $lihs->{vars}->{tmpl} || $m->pvar(__tmpl => 0) || $m->pvar(tmpl => 0);
$m->ustop(notmpl => undef) unless $tmpl;
return $m->Wpop0($prog, v => tavarstv => t => $tmpl, v => \@args) if !$lihs->{vars}->{'__tmpl_'.$tmpl};
my $res = $m->antevars($lihs,@args);
$m->dpop1($prog,$res);
};
=head3 Function riid_tmplvars_init
Initiations to be performed directly before reading textchunk files.
The list/hash definitions may not be done in initialisation as that would prevent those programs that rely on dbm only from parsing their flattened representations with nom2hac/nom2lst.
=cut
sub riid_tmplvars_init {
my ($m,$prog,$lihs,$initvars) = shift->opuc('riid_tmplvars_init',1,@_);$initvars ||= $m->{progvars};
INITVARS: {
# 曽試廢而復: file:/phm/18/10/15/sig/_lng.phm_pub_sig181015.txt::rm_initvars
$initvars->{$_} = $m->pvar($_) for qw(hodie); # 190817 廢tmpl
foreach my $nom (keys %$initvars) {
my $val = $initvars->{$nom};
next unless $val;
$m->lihs_putarb($lihs,$nom => $val);
$m->lihs_putarb($lihs,'__'.$nom => $val); # 或許可廢、progvars已受足保護
};
};
local $_ = $m->pvar(hodie => 1); # || strftime '%Y-%m-%d', $m->plst(progtime => 1);
my @aamd = m(\A(\d{2}(\d{2}))\-(\d{2})\-(\d{2})\Z);
$m->ustop('date hodie %h in incorrect format', h => $_) unless @aamd;
$lihs->putstr(__aaaa => shift @aamd, typ => 'i');
$lihs->putstr(__aa => shift @aamd, typ => 'i');
$lihs->putstr(__mm => shift @aamd, typ => 'i');
$lihs->putstr(__dd => shift @aamd, typ => 'i' );
my (@wwd) = split /\s+/, $m->{sarb}->render_strfamd({}, '%W %w', @aamd[0,2,3]);
$wwd[1] ||= '7'; # sunday expressed as 7 rather than 0
$m->ustop('cant obtain weekday info %W from date %A', W => \@wwd, A => $m->koniug_et(@aamd[0,2,3])) unless @wwd;
$lihs->putstr(__ww => shift @wwd, typ => 'i');
$lihs->putstr(__wd => shift @wwd, typ => 'i');
NO_DEL: {
last;
foreach my $nom (keys %{$m->{lihs}->{hacs}}, keys %{$m->{lihs}->{lsts}}, qw(_antevars_ __dabarels__ _reksekts_ _tmpltoks_ _tmplrels_)) { delete $lihs->{vars}->{$nom} };
%{$m->{lihs}->{hacs}} = ();
%{$m->{lihs}->{lsts}} = ();
# 似已無需大幅刪除 file:/phm/18/10/15/sig/_lng.phm_pub_sig181015.txt::no_del
# 遷移變量: file:/phm/18/10/15/sig/_lng.phm_pub_sig181015.txt::mv_initvars
};
$m->dpop1($prog,1);
};
=head3 Function riid_tmplvars_post
Overwrite to add hook
=cut
sub riid_tmplvars_post {
my ($m,$prog) = shift->ppuc('A2E::Tmplfil::riid_tmplvars_post',@_);
$m->dpop1($prog,1);
};
=head3 Function postkonfig
Wrapper around tmplfil_postkonfig for automatic use in A2E::Prog::new_ready constructor mechanism.
=cut
sub postkonfig {
my ($m,$prog) = shift->qpuc('A2E::Tmplfil::postkonfig', @_) or return;
$m->SUPER::postkonfig;
$m->tmplfil_postkonfig;
$m->qpop1($prog,1);
};
=head3 Function tmplopts
Return a hash consisting of a subset of valid options obtained from configuration variable tmplopts, based on keys supplied as args
=cut
sub tmplopts {
my $m = shift;
my $opts = {};
my @noms = @_;
my $tmplopts = $m->{cache}->{tmplopts};
NOMS: {
last unless @noms;
my $nom = shift @noms;
EVAL_PERL: {
last unless $nom eq 'EVAL_PERL';
last unless $opts->{$nom};
last if $m->superuserp;
$m->uwarn('Refusing for security reasons to set tmplopts EVAL_PERL to %v.', v => $opts->{$nom});
redo NOMS;
};
$opts->{$nom} = $tmplopts->{$nom};
redo NOMS;
};
return $opts;
};
=head3 Function set_template
Prepare the template.
=cut
sub set_template {
my ($m,$prog,$lihs,$tmplang,$tmpl) = shift->lpuc('set_template',@_);
$tmplang ||= $m->pvar('tmplang');
$tmpl ||= $m->pvar('tmpl');
my $template = $m->{ttt2template}->{$tmplang.'_'.$tmpl};
FOUND: {
last unless $template;
$m->pstop(bad_template => 0) unless 'Template' eq ref $template;
$m->{template} = $template;
return $m->dpop1($prog,$template);
};
my $path = $m->set_template_include_path(tmpl => $tmpl, tmplang => $tmplang, lihs => $lihs);
# $m->pstop('sarb not found') unless $m->{sarb};
# $m->pstop('sarb is not a A2E:SArb::Make') unless blessed($m->{sarb}) eq 'A2E::SArb::Make';
# $m->pstop('sarb vars are not tmplvars') unless $m->{sarb}->{vars} eq $m->{lihs}->{vars};
my $opts = $m->tmplopts(qw(INCLUDE_PATH INTERPOLATE ENCODING DEBUG FACTORY RELATIVE ABSOLUTE EVAL_PERL));
$m->{cache}->{tmplopts}->{PARSER} = new Template::Parser $opts or $m->pstop('unable to set parser with options %O', O => $opts);
$opts->{PARSER} = $m->{cache}->{tmplopts}->{PARSER};
my $provider = new A2E::Template::Provider $opts or $m->pstop('unable to set provider with options %O', O => $opts);
$m->{cache}->{tmplopts}->{LOAD_TEMPLATES} = [ $provider ];
$opts = $m->tmplopts(qw(INCLUDE_PATH LOAD_TEMPLATES EVAL_PERL PLUGIN_BASE DEBUG RELATIVE ABSOLUTE));
$m->{cache}->{tmplopts}->{CONTEXT} = new_ready A2E::Template::Context $opts, $m->{sarb} or $m->pstop('unable to set context with options %O', O => $opts);
# Template::Manual::Config http://template-toolkit.org/docs/manual/Config.html#section_VARIABLES
$m->{cache}->{tmplopts}->{NAMESPACE} = { prog => $m->{progvars} };
$m->{cache}->{tmplopts}->{DEBUG_ALL} = $m->{debug};
$m->{cache}->{tmplopts}->{COMPILE_EXT} = '.ttc';
$m->{cache}->{tmplopts}->{ABSOLUTE} = 1;
$m->{cache}->{tmplopts}->{RELATIVE} = 1;
$m->{cache}->{tmplopts}->{STRICT} = 0; # TODO set to 1 for better debugging ASAP
$m->{cache}->{tmplopts}->{COMPILE_DIR} = '/adv/tmpl/ttc';
use Template::Namespace::Constants;
$m->{cache}->{tmplopts}->{NAMESPACE} = {
__vars__ => Template::Namespace::Constants->new($lihs->{vars}),
__lsts__ => Template::Namespace::Constants->new($lihs->{lsts}),
__hacs__ => Template::Namespace::Constants->new($lihs->{hacs}) };
$opts = $m->tmplopts(qw(INCLUDE_PATH LOAD_TEMPLATES TAG_STYLE EVAL_PERL PLUGIN_BASE DEBUG DEBUG_ALL CONTEXT ENCODING RELATIVE ABSOLUTE COMPILE_EXT COMPILE_DIR NAMESPACE STRICT));
$opts->{AUTO_RESET} = 1; # TODO set to 1 for better debugging ASAP
$opts->{INCLUDE_PATH} = $path;
# $opts->{PRE_PROCESS} = sprintf '%s_tmpl.txt', $tmplang; # works only at runtime anyway
$template = new Template $opts or $m->pstop(new_template => O => $opts);
$m->pstop(bad_template_opts => O => $opts) unless 'Template' eq ref $template;
$m->pstop(context_no_sarb => undef) unless $template->service->{CONTEXT}->{sarb};
$m->{template} = $template;
$m->{ttt2template}->{$tmplang.'_'.$tmpl} = $template;
$m->dpop1($prog,$template);
};
sub set_template_riidvars { # file:/phm/19/05/12/sig/_lng.phm_pub_sig190512.txt::riidvars set_template and read tml-specific liniverb.txt
my ($m,$prog,$lihs,$tml,$tmpl) = shift->lpuc('set_template_riidvars',@_);
my $template = $m->set_template($lihs,$tml,$tmpl);
$m->{tmplang_linivars}->{$tml} ||= {};
my $linivars = $m->{tmplang_linivars}->{$tml};
$m->decho('for %f found linivars %L', f => $tml, L => $linivars);
RIID: {
last if %$linivars;
my $paf = catfile $m->pvar(tmplapptmplangdir => 1), 'liniverb.txt';
$m->pstop('missing file %f', f => $paf) unless -r $paf;
$m->riid_tmplvars_fayl($paf, abs => 1, tmplvars => $linivars, setnomval_pur => 1, litstag => 't', typ => 'd');
$m->pwarn('after reading got linivars %L', L => $linivars);
$m->{tmplang_linivars}->{$tml} = $linivars;
};
# 插入 litstag 選项, 但其實可更快。唯未知是否需保留 $linivars 與 $lihs->{tvars} 分别身份
# foreach my $k (keys %$linivars) { my $v = $linivars->{$k};next unless $v;$lihs->putstr($k => $v, litstag => 't', typ => 'd') };
%{$lihs->{tvars}} = %$linivars;
#
# s(vars)(tvars)
$m->pwarn('reset undl_verb to %v for tml %f and tmpl %t', f => $tml, t => $tmpl, v => $lihs->{tvars}->{undl_verb}); #
$m->dpop1($prog,$template);
};
sub template_include_path {
my $m = shift;
return $m->{template}->context->config->{INCLUDE_PATH};
};
sub template_include_file {
my ($m,$prog,$fb) = shift->ppuc('template_include_file',@_);
my @dirs = eval { @{$m->template_include_path} };
$m->pstop(no_include_path => f => $fb) unless @dirs;
foreach my $dir (@dirs) {
my $fayl = catfile $dir, $fb;
next unless -e $fayl;
return $m->dpop1($prog,$fayl);
};
$m->dpop($prog);
};
sub template_context { return shift->{template}->context };
sub template_include { # invoke a file or a block, for file invocation see file:/adv/perl/A2E/MLHT.pm.tmpl::template_include
my ($m,$prog,$fi,$vars,$fo,%opts) = shift->ppuc('template_include',@_);
my $template = $opts{template};
$m->pstop('invalid template supplied in optional argument') if $template and not 'Template' eq ref $template;
$template = $m->{template};
$m->pstop('no template in object') if !$template;
$m->pstop('invalid template in object') if 'Template' ne ref $template;
my $c = $template->context;
$m->pstop('invalid template in object') if 'A2E::Template::Context' ne ref $c;
PREPROC: {
last if -r $fi;
last if $c->{BLOCKS}->{$fi};
my $tmplang = $m->pvar(tmplang => 1);
my $tmpltxt = catfile '', 'adv', 'tmpl', 'a2e', $tmplang, sprintf '%s_tmpl.txt', $tmplang;
$c->process($tmpltxt,$vars);
};
local $_ = eval { $c->include($fi,$vars) };
$m->pstop('template block %f crashed with message: %m', f => $fi, m => Dumper($@)) if $@;
my ($so) = m(\A\s*(.*\S)\s*\Z)s;
return $m->dpop1($prog,$so) unless $fo;
$m->fayl_put_str($fo,$so);
$m->dpop1($prog,$fo);
};
=head Function tmplfil_special
Make externally hooked-in directives like
special process bautext_tmpl.txt
possible
=cut
our %TMPLVARS_FAYL_RANKS = ( important => 2, normal => 1, unimportant => 0 ) ;
sub tmplfil_special_put {
my ($m,$prog,$lihs,$verb,$fun,%opts) = shift->opuc('tmplfil_special',[qw(nom fun)],@_);
$m->{tmplfil_special}->{$verb} = $fun;
$m->dpop1($prog,$fun);
};
sub tmplfil_special_get {
my ($m,$prog,$lihs,$fun,%opts) = shift->opuc('tmplfil_special_get',[qw(verb2fun)],@_);
$m->dpop1($prog,$fun);
};
=head3 Functions shared with A2E::MLHT::litscat
=head3 Function num2alpha
take an integer counter value, return a counter value that uses alphabet characters a-z, aa-az, ba-bz, .. za-zz, aaa-aaz, aba-abz, ... eicosahexesimal ($ALPHA_BASIS-based) system with 'z' as zero.
0 => z
1 => a
25 => y
26 => az
27 => aa
52 => bz
53 => ba
=cut
our $ALPHA_BASIS = 26;
our $ALPHA_OFSET = 96;
sub num2alpha {
my $m = shift;
$m->dpuc('num2alpha', @_);
my $num = shift;
my @mods = ();
my $mod = 0;
while ($num) {
$mod = $num % $ALPHA_BASIS; # 53 % 26 = 1
unshift @mods, $mod;
$m->dgot(num => $num, mod => $mod, mods => \@mods);
} continue {
$num /= $ALPHA_BASIS; # 53 / 26 => 2.03846153846154
$num = int $num; # => 2
};
unshift @mods, 0 unless @mods;
my $str = join '', map { $mod = $_ || $ALPHA_BASIS;chr($ALPHA_OFSET + $mod) } @mods;
$m->dpop1('num2alpha', $str);
return $str;
};
sub num2Alpha {
my $m = shift;
$m->dpuc('num2Alpha', @_);
local $ALPHA_OFSET = 64;
my $str = $m->num2alpha(@_);
$m->dpop1('num2Alpha', $str);
return $str;
}
sub numpad {
my $m = shift;
$m->dpuc('numpad', @_);
my $str = shift;
my $strlen = length $str;
my $len = shift || $strlen;
my $pad = shift || '0';
$strlen++;
$str = $pad . $str for $strlen .. $len;
$m->dpop1('numpad', $str);
return $str;
}
=head3 Function alpha2num
take an alphabetic representation of an integer and return the represented integer.
reverse of num2alpha
z -> 0
a -> 1
e -> 5
j -> 10
y -> 25
az -> 26
aa -> 27
ay -> 51
bz -> 52
dz -> 104
=cut
sub alpha2num {
my $m = shift;
$m->dpuc('alpha2num', @_);
my $alpha = shift; # 'ba'
my @alphas = unpack 'C*', $alpha; # ('98', '97');
my $num = 0;
my $faktor = 1;
while (my $keta = pop @alphas) {
next unless $keta > $ALPHA_OFSET;
my $ofs = $keta - $ALPHA_OFSET;
next unless $ofs < $ALPHA_BASIS;
my $plus = $ofs * $faktor;
$m->dgot(ofs => $ofs, keta => $keta, alphas => \@alphas, plus => $plus, num => $num, faktor => $faktor);
$num += $plus;
} continue { $faktor *= $ALPHA_BASIS };
$m->dpop1('alpha2num', $num);
return $num;
};
sub Alpha2num {
my $m = shift;
$m->dpuc('Alpha2num', @_);
my $ALPHA_OFSET = 64;
my $str = $m->alpha2num(@_);
$m->dpop1('Alpha2num', $str);
return $str;
}
sub romnum {
my ($m,$prog,$num) = shift->ppuc('romnum',@_);
my $rom = roman $num;
$m->dpop1($prog,$rom);
}
=head3 Function sup8fol2nom
Generate lit of next level
Examples:
sup8fol2nom($lihs,'top', 'abc') => 'abc'
sup8fol2nom($lihs,'top', 'Abc') => 'Abc'
sup8fol2nom($lihs,'top', '123') => '123'
sup8fol2nom($lihs,'top', '_abc') => 'top_abc'
sup8fol2nom($lihs,'top', '~123') => 'top123'
sup8fol2nom($lihs,'top', '~abc') => 'topabc'
sup8fol2nom($lihs,'top', 'dd01', 2) => '01'
sup8fol2nom($lihs,'oas1908', '_top') => 'oas1908top'
sup8fol2nom($lihs,'mm', '~mm01', 2) => 'mm01'
args := sup, fol
rets := nom
sup => 'top1'
fol => '~a'
nom => 'top1a'
=cut
sub sup8fol2nom {
my ($m,$prog,$lihs,$sup,$fol) = shift->lpuc('sup8fol2nom',@_);
FOLRX: { # file:/phm/19/01/W00/sig/_lng.phm_pub_sig19W00.txt::folrx
my $val = $lihs->getstr($sup.'_folrx');
last unless $val;
($fol) = $fol =~ m($val);
};
my $nom = $fol;
PFX: {
my $pfx = substr $fol, 0, 1;
my $ifx = '';
IFX: {
last if $pfx eq '~';
last PFX unless $pfx eq '_';
$ifx = '_' unless $sup =~ m(\d\Z);
};
$fol = substr $fol, 1;
$nom = $sup . $ifx . $fol;
};
$m->dpop1($prog,$nom);
};
=head3 Function grupvar
=cut
sub grupvar { my ($m,$stem,$fol) = @_;$stem.'__'.$fol };
=head3 Function grupfill
Parse-render according to maketext syntax, expanding text variables and markup functions using group-local and global definitions.
Local variables $m->{grupvars} are to be made available at certain junctures by $m->set_grupvars.
=cut
sub grupfill {
my ($m,$prog,$lihs,$str,%opts) = shift->opuc('grupfill',1,@_);my $grup = $opts{grup};
my %grupvars = %{$m->set_grupvars($grup)} if $grup;
GRUPVARS: {
%grupvars = $m->ref2hash($opts{gvars});
last if %grupvars;
%grupvars = $m->ref2hash($m->{grupvars});
last if %grupvars;
$grup = $m->{lits}->{__nom};
last unless $grup;
%grupvars = %{$m->set_grupvars($grup)} if $grup;
};
$m->{sarb}->vars_transform(\%grupvars,$str);
};
sub fayl_fil_lst { # read strings from a file, interpolate them with grupfill, return as list; useful for _deps: file:/adv/perl/A2E/MLDK.pm.tmpl::fayl_fil_lst, file:/sig/oas/19/04/metzW4/tra/vend/Daikufile::fayl_fil_lst
# optional 2nd argument limits strings by regex, defaults to qr(\A\w)
my ($m,$prog,$fayl,$rx) = shift->ppuc('fayl_fil_lst',@_);$rx ||= qr(\A\S+\Z);
return $m->dpop($prog) unless -r $fayl;
my @vals = ();
push @vals, map { $m->grupfill($_) } grep { m($rx) } $m->fayl_get_lst($fayl,1);
$m->dpop($prog,@vals);
};
=head3 Function $m->set_grupvars($grup)
Make local variables (e.g. ep_url = ...) globally available to maketext functions by storing them in $m->{grupvars} and by side-effect in $m->{nom2gvars}->{$grup}
This is useful during reading.
During output, strict local availability through grup_add_grupvars is enough.
OLD TODO:
This mechanism operates both at the tmplfil/parsing level in grupfill and at the rendering level in litscat_simpl, litscat etc where grupfill is also invoked.
It is made necessary by the limitations of the maketext interface, which requires a static vocabulary hash.
Scoping may have been broken, see grupvars in /phm/15/04/05/sig/_lng.phm_pub_sig150405.txt, but suspicion was in this case correctly on the Template module, cf adv1801.litren.
INDEED significantly improved by substituting C in template_include with C file:/phm/19/05/08/sig/_lng.phm_pub_sig190508.txt::tmpl.
One way to clean the system would be to let $m->{sarb}->transform accept a function or an ancestry tree of vocabularies as $grupvars argument.
=cut
sub set_grupvars ($$) { # 1
my ($m,$prog,$lihs,$grup,%opts) = shift->opuc('set_grupvars',1,@_);
$m->pstop(funnovar => v => 'nom') unless $grup;
$opts{gvars} = {};
my $gvars = $m->grup_add_grupvars($grup,%opts);
%{$m->{grupvars}} = %$gvars; # GRUPVARS_REFKONST file:/phm/20/10/18/sig/_lng.phm_pub_sig201018.txt::grupvars
$m->dpop1($prog,$m->{grupvars});
};
=head3 Functions that implement implicit assignments of groups of lines between brackets
Functionality envisaged in dok:adv_pub_litscat1004 and first implemented for version 0.4.0 aka progver 400.
=head4 nom2lits: return group properties pertaining to a group name
When we are in maketext file parsing mode it is enough to look up these properties in $m->{nom2lits}.
But when we are in vocabulary table reading mode, we may have to reconstruct $m->{nom2lits} from available variables such as, for group 'top', would be
top__fols
top__vars
top__lsts
top__hacs
=cut
sub nom2lits { # '$lits'
my ($m,$prog,$lihs,$nom) = shift->lpuc('nom2lits',@_);
return $m->dpop($prog) unless $nom;
my $lits = $m->{nom2lits}->{$nom};
my $var = $m->grupvar($nom,'nom');
my $val = $lihs->getstr($var);
return $m->Wpop0($prog, u => 'document %d contains no %n section', g => $nom, d => $lihs->{vars}->{dok}) if !$val;
$m->pstop(d => 'value of %g is %v, should be %n', g => $var, v => $val, n => $nom) if $val ne $nom;
$lits->{__nom} = $nom;
$var = $nom.'__sup';$lits->{__sup} = $lihs->getstr($var);
foreach my $typ (qw(vars lsts hacs)) {
$var = $nom.'__'.$typ;
$val = $lihs->getstr($var);
next unless $val;
my @lst = $m->text2list($val);
my %hac = ();
$hac{$_} = 1 for @lst;
$lits->{'__'.$typ} = \%hac;
};
$m->{nom2lits}->{$nom} = $lits;
$m->dpop1($prog, $lits);
};
=head4 $gvars = $m->grup_add_grupvars($nom, grup => $grup, lihs => $lihs, non_rekurs => $non_rekurs, gvars => $gvars)
Find attributes of current grup (text node) and return them.
$nom and $grup start out as same but diverge during recursion. $nom then becomes a parent group to which we have recurred while $grup is the original for which we are seeking the attributes.
$gvars is the hashref that we are gradually building up. If not specified, it starts out empty.
The process has been sped up by caching the upper levels in $m->nom2gvars->{$lang} so that in each instance only one level of recursion is needed.
Recursion can be turned off altogether by setting option non_rekurs => 1.
We can search in an external document's tree by setting $lihs as done e.g. in file:/adv/perl/A2E/MLMK.pm.tmpl::lihs_import_grupvars
=cut
our %GRPTYP = (vars => '$', lsts => '@', hacs => '%');
sub grup_add_grupvars {
my ($m,$prog,$lihs,$gvars,$nom,%opts) = shift->ogpuc('grup_add_grupvars',1,@_);
my $grup = $opts{grup} || $nom;
my $top = $grup eq $nom;
my $non_rekurs = $opts{non_rekurs};
my $lang = $opts{lang} || $m->pvar(lang => 1);
return $m->dpop($prog) unless $nom;
my $lits = $m->nom2lits($lihs,$nom); # is reconstructed from vars when not available
return $m->Wpop0($prog, d => 'no lits available for node %n', n => $nom) if !$lits;
my $sup = $lits->{__sup};
NOMGVARS: { # if pre-stored group variables are available, no need to recurse further up from here
my %nomgvars = $m->ref2hash($m->{nom2gvars}->{$nom});
last unless %nomgvars;
foreach my $k (keys %nomgvars) {
next if defined $gvars->{$k}; # write only what was not written at lower level
$gvars->{$k} = $nomgvars{$k};
};
return $m->dpop1($prog,$gvars);
};
my $setgvars = sub {
my ($tyn) = @_; # 'lsts'
my $typ = $GRPTYP{$tyn}; # '@'
my %folp = $m->ref2hash($lits->{'__'.$tyn});
my $folssn = $m->grupvar($nom,$tyn); # 'sig__lsts'
my $folss = $lihs->getstr($folssn); # '+slngs+sems+langs+'
my @fols = !%folp ? $m->text2list($folss) : keys %folp; # qw(slngs sems langs)
foreach my $fol (@fols) {
next if defined $gvars->{$fol}; # ignore if already defined at lower level from where we are recurring upward
next if !$top and $lihs->{hacs}->{grupvars_nonheredp}->{$fol}; # file:/phm/19/07/22/sig/_lng.phm_pub_sig190722.txt::nonheredp
my $nomfol = $lits->{__nom} . '_' . $fol; # 'sig_slngs'
my $val = $opts{lang} ? $lihs->fgetval($nomfol) : $lihs->getval($nomfol); # nomfol2val: '+de+zh+'
do { $m->decho(nogvar => g => $tyn, n => $nomfol, l => $lits->{__nom});next } unless defined $val;
$val = $m->strval_defarb($lihs,$typ,$nomfol,$val,%opts) if '$' ne $typ and not ref $val;
$gvars->{$fol} = $val;
next if $nom eq $grup;
$gvars->{$fol.'__grup'} = $nom; # 未試、建於 file:/phm/20/09/28/sig/_lng.phm_pub_sig200928.txt::var2lit, 用於 file:/adv/perl/A2E/MLHT.pm.tmpl::_vargrup
};
};
foreach my $tyn (qw(vars lsts hacs)) {
&$setgvars($tyn) };
$m->grup_add_grupvars($sup, grup => $grup, non_rekurs => $non_rekurs, gvars => $gvars, lihs => $lihs) unless $non_rekurs;
$m->{nom2gvars}->{$nom} = $gvars;
$m->dpop1($prog,$gvars);
};
=head4 Function grupvars_getstr,grupvars_getlst,grupvars_gethac,grupvars_getval
Take variable value from local group or next possible parent or global variables.
$val = $m->grupvars_getstr($lihs, $nom => $grp)
=cut
sub lihs_gettypr { # read a string from memo or disk and coerce into type
my ($m,$prog,$lihs,$nom,$typ) = shift->lpuc('lihs_gettypr',@_);
my $val = $lihs->getval($nom);
return unless $val;
$val = $m->str2arb($val) if $typ and not ref $val;
my $ref = ref $val;my $tref = $lihs->tref($typ);
$m->ustop('value %v is of type %r but should be %s', v => $val, r => $ref, t => $tref) unless $ref eq $tref;
$m->dpop1($prog,$val);
};
sub grupvars_supget {
my ($m,$prog,$lihs,$nom,$grp,$typ) = shift->lpuc('grupvars_supget',@_);
return $m->dpop($prog) unless $grp;
$lihs = $m->get_lihs($lihs);
my $lits = $m->nom2lits($lihs,$grp);
return $m->dpop($prog) unless $lits;
my $vnom = join '_', $grp, $nom;
my $val = $lihs->gettypr($vnom,$typ);
return $m->dpop1($prog,$val) if defined $val;
$val = $m->lihs_gettypr($lihs,$vnom,$typ);
return $m->dpop1($prog,$val) if defined $val;
$val = $m->grupvars_supget($lihs,$nom,$lits->{__sup},$typ);
$m->dpop1($prog,$val);
};
sub grupvars_getvalr {
my ($m,$prog,$lihs,$nom,$grp,$typ) = shift->lpuc('grupvars_getvalr',@_);
$grp ||= $m->{lits}->{__nom};
$m->decho(nogrupvar => n => $nom) unless $grp;
my $val = $m->grupvars_supget($lihs,$nom,$grp,$typ);
return $m->dpop1($prog,$val) if defined $val;
$val = $lihs->getvalr($nom,$typ);
$m->dpop1($prog,$val);
};
sub grupvars_getval {
my ($m,$prog,$lihs,$nom,$grp,$typ) = shift->lpuc('grupvars_getval',@_);
my $val = $m->grupvars_getvalr($lihs,$nom,$grp,$typ);
return unless $val;
$lihs = $m->get_lihs($lihs);
my $typref = $lihs->tref($typ);
my $valref = ref $val;
$m->ustop(badref => r => $valref, t => $typref, n => $nom) unless $valref eq $typref;
$m->dpop1($prog,$val);
};
sub grupvars_getstr {
my ($m,$prog,$lihs,$nom,$grp) = shift->lpuc('grupvars_getstr',@_);
my $val = $m->grupvars_getvalr($lihs,$nom,$grp);
$m->dpop1($prog,$val);
};
sub grupvars_getlst {
my ($m,$prog,$lihs,$nom,$grp) = shift->lpuc('grupvars_getlst',@_);
my $ref = $m->grupvars_getval($lihs,$nom,$grp,'@');
return $m->dpop($prog) unless $ref;
$m->dpop($prog,@$ref);
};
sub grupvars_gethac {
my ($m,$prog,$lihs,$nom,$grp) = shift->lpuc('grupvars_gethac',@_);
my $ref = $m->grupvars_getval($lihs,$nom,$grp,'%');
return $m->dpop($prog) unless $ref;
$m->dpop($prog,%$ref);
};
=head4 Function supnum2fol
args := sup, num
rets := fol
sup => top1
num => 2
fol => b
sup :: name stem of current node i.e. name of upper node
num :: ordinal number
=cut
sub supnum2fol {
my $prog = 'supnum2fol';my $m = shift;$m->dpuc($prog, @_);
my ($sup,$num) = @_;
$m->pstop(nonnumsfx => n => $num) unless $num =~ m(\A\d+\Z);
my $fol = $sup =~ m(\D\Z) ? $num : $m->num2alpha($num);
$m->dpop1($prog, $fol);
}
=head4 Function grupopen_supfol2nomfol
Generate the full name and leaf name that need to be stored in the vocabulary database, e.g. in variables like top__fols, so as to enable reconstruction of the group during output formatting.
$m->grupopen_supfol2nomfol($lihs,'top', 'intro') => 'intro', 'intro'
$m->grupopen_supfol2nomfol($lihs,'top', '') => 'top1', '~1'
args := nom0, fol0
rets := nom, fol
nom :: resulting full name of node
fol :: resulting leaf name of node
nom0 :: initial name of node, i.e. name of upper node
fol0 :: initial name of leaf, i.e. what was found when opening the group
nom0 => 'top', fol0 => 'intro', nom => 'intro', fol => 'intro'
nom0 => 'top', fol0 => '_intro', nom => 'top_intro', fol => '_intro'
nom0 => 'top', fol0 => '', nom => 'top1', fol => '~1'
TODO: remove redundancies/conflicts with sup8fol2nom
=cut
sub grupopen_supfol2nomfol { # $nom, $fol
my ($m,$prog,$lihs,$nom,$fol) = shift->lpuc('grupopen_supfol2nomfol',@_);
NOM: {
FOL: {
last if !$fol;
$nom = $m->sup8fol2nom($lihs,$nom,$fol);
last NOM;
};
$m->ustop(topanon => undef) unless $nom;
NUM: {
my $num = ++$m->{lits}->{__num};
$fol = $m->supnum2fol($nom, $num);
};
$nom .= $fol;
$fol = '~' . $fol;
};
$m->dpop($prog,$nom,$fol);
};
=head5 Function grupopen_jungils file:/adv/perl/A2E/OLD/Tmplfil.old::grupopen_jungils
=head4 Function grupopen
args := ignor, lini
rets := ok, nom
lini :: line to be parsed, starts with C<($fol0> and may end with C<)>, in which case the C form that invokes values from elsewhere is found.
ignor :: whether to ignore this section
ok :: successfully parsed as a group opener
nom :: name of the group that we entered into
Open a litsgrup, set up current level's $m->{lits} with builtin variables.
__sup: name of superior node hashref, data must be available via $m->{nom2lits} under this index
__lvl: current hiearchy level, starting from 1
__num: sequential order number at the current level
__nom: absolute name of this node
__fol: leaf name such that from this in combination with the absolute name of the upper node the absolute name of this node can be derived: either a suffix to be attached literally or an absolute name prefiged by ^
__fols: ordered list of leaf names (cf __fol) of members of this node
Line to be parsed can take a variety of forms, e.g.
(top /proc+alineas/proc+sekt+jungil+alineas/proc+alineas/ # ending ) comes in later line
(mlhtdefs)
(papridir /proc+tititemlist/ ! +papri+europarl0309+konf0506+europarl0507+)
Internal variables
$nom :: textchunk name
$m->{nom2lits} :: table of hashrefs representing nodes
$m->{lits} :: current node (?)
$lits :: to-be-opened node (?)
=head5 grupopen_elgrup, kopivars, ...
Moved to file:/adv/perl/A2E/OLD/Tmplfil.old::grupopen_elgrup
Functionality is now taken over by kopifols, syntax still quite similar.
The following should work:
(tab1 @tabxs
...
)
(tab2 ! tab1)
A longer way to write tab2 would be
(tab2
@kopilits = |+tab1+fols+|
)
It should still be possible to write
(tab2 @tabxs2 ! tab1)
(tab2 @tabxs2 ? tab1)
etc. The latter would mean that any previous definition of tab2, e.g. one coming from a variant/language file, would take precedence.
This syntax is untested but the @kopilits form does work.
=head5 kopilits
=cut
our %nonkopivarp = ( _nom => 1, _lvl => 1, _sup => 1, _num => 1, _fol => 1) ; #
sub kopivars_setarbs { # merge tree variables set locally with imported ones
my ($m,$prog,$lihs,$optsr,$gvars,$typ,$merge,$lit0,$lit1,$lihs0) = shift->tgpuc('kopivars_setarbs',@_);my %opts = $m->ref2hash($optsr);
my $treg = $lihs->treg($typ); # hacs
my $lit0typ = join '__', $lit0, $treg; # srctab__hacs
my @atr0l = $m->val2lst($lihs->getstr($lit0typ,$lihs0)); # ('voks', 'sizs')
return $m->dpop($prog) unless @atr0l;
my $lit1typ = join '__', $lit1, $treg; # 'dsttab__hacs'
my @atr1l = $m->textsep2list($lihs->getstr($lit1typ)); # ('alns')
my %atr1p = ();$atr1p{$_} = 1 for @atr1l; # (alns => 1)
$m->{nom2lits}->{$lit1}->{'__'.$treg}->{$_} = 1 for @atr1l;
while (my ($k,$v) = each %{$m->{nom2lits}->{$lit1}->{'__'.$treg}}) { push @atr1l, $k if $v and !$atr1p{$k} }; # fix potential inconsistencies
foreach my $atr0 (@atr0l) {
next if $nonkopivarp{$atr0};
my $nom0 = $lit0.'_'.$atr0;
my $val0 = $lihs->getstr($nom0,$lihs0);
my $nom1 = $lit1.'_'.$atr0;
next unless defined $val0;
my $val1 = $lihs->getstr($nom1);
#
# my $arb1 = $lihs->{vars}->{$nom1};
my $arb1 = $lihs->vgetval($nom1);
#
do { $arb1 = $m->str2arb($val1) } unless ref $arb1;
my $arb0 = $val0;if (ref $arb0) { $val0 = $m->arb2str($arb0) } else { $arb0 = $m->str2arb($val0) };
$arb0 = &$merge($arb0,$arb1);
$val0 = $m->arb2str($arb0);
$lihs->putstr($nom1 => $val0, %opts);
$gvars->{$atr0} = $arb0;
# $lihs->{vars}->{$nom1} = $arb0 unless $dyna;
do { push @atr1l, $atr0;$atr1p{$atr0} = 1 } unless $atr1p{$atr0};
$lihs->{$treg}->{$nom1} = $arb0;
$m->{nom2lits}->{$lit1}->{'__'.$treg}->{$atr0} = 1;
};
my $atr1s = join '+', '', @atr1l, '';
$lihs->putstr($lit1typ => $atr1s, %opts); # '+voks+sizs+alns+', listvar not needed for internal purpose
$m->dpop($prog,@atr1l); # allow push
};
sub kopivars { # copy attributes of group, cf examples in file:/sig/oas/19/05/demcW5/tra/avoc.txt::/\bkopilits\b/
my ($m,$prog,$lihs,$optsr,$lit0,$lit1) = shift->tpuc('kopivars',@_);my %opts = $m->ref2hash($optsr);
my $prt = $opts{prt} || '';
my $dyna = $opts{dyna} ? 1 : 0;
my ($dok0,$lihs0,$lit0r) = ();
if ('ARRAY' eq ref $lit0) { # dok_kopivars: read from external document; works but need to adapt dok2tmplvars to new file-storage .lits/zh/* paradigm
($dok0,$lit0,$lihs0) = @$lit0;
$lihs0 ||= $m->dok2tmplvars(d => $dok0);
$lit0r = [$dok0,$lit0,$lihs0];
};
$lihs0 ||= $lihs;
my %grupvars = ();
my $vars0nom = $lit0.'__vars';
my @vars0 = $m->val2lst($lihs->getstr($vars0nom,$lihs0));
my $vars1nom = $lit1.'__vars';
my @vars1 = $m->val2lst($lihs->getstr($vars1nom));
$m->{nom2lits}->{$lit1}->{__vars}->{$_} = 1 for @vars1;
foreach my $var (@vars0) { # file:/phm/20/11/19/sig/_lng.phm_pub_sig201119.txt::foreach_var_fols_vars
next if $nonkopivarp{$var};
my $nom0 = $lit0.'_'.$var;
my $val0 = $lihs->getstr($nom0,$lihs0);
do { $m->pwarn('found ref value for string var %n', n => $nom0);$val0 = $m->arb2str($val0) } if ref $val0;
next unless length $val0; # dont copy '' but do copy '0' values
my $nom1 = $lit1.'_'.$var;
my $val1 = $lihs->getstr($nom1,$lihs);
$val1 = length $val1 ? $val1 : $val0;
$lihs->putstr($nom1 => $val1, %opts);
# 似冗餘, 且已不能容忍直接指定
# $lihs->{vars}->{$nom1} = $val1 unless $dyna;
#
do { push @vars1, $var;$m->{nom2lits}->{$lit1}->{__vars}->{$var} = 1 } unless $m->{nom2lits}->{$lit1}->{__vars}->{$var};
$grupvars{$var} = $val1;
};
VARS1VAL: {
@vars1 = grep {$_} @vars1;
last unless @vars1;
my $vars1val = join '+', '', @vars1, '';
$lihs->putstr($vars1nom => $vars1val, %opts);
# $lihs->{vars}->{$vars1nom} = $vars1val unless $dyna;
};
my %typ2mrg = (
'@' => sub { my ($l1,$l2) = @_;my @l = $m->uniqpush($l2,$l1);\@l },
'%' => sub { my ($h1,$h2) = @_;my $h = $m->hashpush('ad',$h1,$h2);$h } );
$m->kopivars_setarbs({ %opts, gvars => \%grupvars },$_,$typ2mrg{$_},$lit0,$lit1,$lihs0) for '@','%';
$m->dpop($prog,%grupvars);
};
sub kopifols { # copy complete info tree, e.g. table, cf examples in file:/sig/oas/19/05/demcW5/tra/avoc.txt::/\bkopilits\b/
my ($m,$prog,$lihs,$optsr,$lit0,$lit1) = shift->tpuc('kopifols',@_);my %opts = $m->ref2hash($optsr);
my $prt = $opts{prt} || '';
my $dyna = $opts{dyna} ? 1 : 0; # in reading stage where possibilities are more open we only store string variables
my $verbose = $m->pvar(verbose => 1);
$opts{echo} ||= $verbose;
$m->decho('kopifols [prt %p] de %a al %b', p => $prt, a => $lit0, b => $lit1);
my ($dok0,$lihs0,$lit0r) = ();
if ('ARRAY' eq ref $lit0) { # importing from external document via $lit0 record argument $lit0r derived from expr as in file:/sig/oas/19/07/jnwpW7/tra/publ.txt::jnwpW7_papl
($dok0,$lit0,$lihs0) = @$lit0;
$lihs0 ||= $m->dok2tmplvars(d => $dok0);
$lit0r = [$dok0,$lit0,$lihs0];
};
$lihs0 ||= $lihs;
$lit0r ||= $lit0;
my $lit1nom = $lihs->getstr($lit1.'__nom');
$m->pwarn('%n has bad nom %v even before kopivars', n => $lit1, v => $lit1nom) unless !$lit1nom or $lit1nom eq $lit1;
my %grupvars = $m->kopivars($optsr,$lit0r,$lit1);
# file:/phm/20/11/19/sig/_lng.phm_pub_sig201119.txt::lit1nom_korr
FOLS: {
last unless 'fols' eq $prt;
my %nomval = ();
local $_;
foreach my $k (qw(_fols _frm)) { # __fols__frm
my $l1k = $lit1.'_'.$k;
my $v = $lihs->getstr($l1k);
next if $v;
my $l0k = $lit0.'_'.$k;
$v = $lihs0->getstr($l0k);
$nomval{$l1k} = $v;
$grupvars{$k} = $v;
};
my $setnomval = sub {
foreach my $k (keys %nomval) {
my $v = $nomval{$k};
next unless $v;
$lihs->defstr($k => $v, %opts);
} };
&$setnomval;
my @fols = $m->text2list($nomval{$lit1.'__fols'});
foreach my $fol (@fols) {
my $nom0 = $m->sup8fol2nom($lihs,$lit0,$fol);
my $nom1 = $m->sup8fol2nom($lihs,$lit1,$fol);
#
# next if $lihs->{vars}->{$nom1}; # allow overwriting in grup into which we import
next if $lihs->vgetval($nom1); # allow overwriting in grup into which we import
#
my $nom0r = $dok0 ? [$dok0,$nom0,$lihs0] : $nom0;
$m->kopivars($optsr,$nom0r,$nom1);
%nomval = ();
$nomval{$nom1.'__sup'} = $lit1;
my $val0 = $lihs0->getstr($nom0);
if ($val0) { $nomval{$nom1} = $val0 } else { $nomval{$nom1.'__nom'} = $nom1 }; # 或名或値規則 file:/phm/20/11/19/sig/_lng.phm_pub_sig201119.txt::nomnom_xor_nomval
&$setnomval;
$m->kopifols($optsr,$nom0r,$nom1);
};
};
$m->dpop($prog,%grupvars);
};
sub kopilits { # copy attributes and optionally leaves from a list of text blocks; in initial more dynamic stage $dyna reading attributes is enough; leaves are useful only in A2E::MLHT::litscat context; attributes are needed because they can contain reading directives like '@slngs'
my ($m,$prog,$lihs,$optsr,$gvars,$litstem) = shift->tgpuc('kopilits',@_);my %opts = $m->ref2hash($optsr);
my $val = $lihs->getstr($litstem.'_kopilits',$lihs);
return $m->dpop($prog) unless $val;
my $dyna = $opts{dyna} ? 1 : 0;
$opts{lihs} ||= $lihs;
$opts{nonstorp} = !$dyna;
$opts{dyna} = $dyna;
$opts{litstag} = $opts{flng} && $opts{litstag}; # neutra se non legita da *.${flng}.txt
my @lits = $m->val2lst($val);
foreach my $lit (@lits) {
($lit,my $prt) = $m->val2lst($lit);
$opts{prt} = $dyna ? 'vars' : $prt || 'vars';
LITREF: { # e.g. file:/sig/oas/19/07/jnwpW7/tra/publ.txt::jnwpW7_papl
# file:/phm/19/07/21/sig/_lng.phm_pub_sig190721.txt::dokkopilits
last if ref $lit;
local $_ = $lit;
my ($sep) = m((\W));
last unless $sep;
$lit = $m->textsep2listref($lit,$sep)
};
my %grupvars1 = $m->kopifols(\%opts,$lit,$litstem); # kopifols_novopts
$gvars->{$_} ||= $grupvars1{$_} for keys %grupvars1;
};
$m->dpop1($prog,$gvars);
};
=head5 main function grupopen
C<$1> $_ is a line that is found to match '\A\('.
C<$2> $rank_ignor if on means that processing is not needed because we are currently reading only configuration values and not text
TODO: enable verbatim processing for documentation purposes as suggested in adv1801
(_vbrv<
# hier dann nicht mehr nötig: special = verbatim EOT
( @lc
活性領域を含む活性領域基板層を有する基板中に構成された半導体装置であって、
(_ol=
# hier dann nicht mehr nötig: special = litverb
labfmt = （$(alpha|${_num})）
前記活性領域基板層上に誘電体層を配置するステップと、
(
第１のマスクを使用して、
前記活性領域上の前記誘電体層中にコンタクトホールを形成し、
前記コンタクトホールの周囲の前記誘電体層中に静電気放電保護開口を形成するステップと、
)
(
第２のマスクを使用して、前記コンタクトホールおよび静電気放電保護開口中にオーミックコンタクトメタライゼーションをデポジットして、
前記活性領域上の前記誘電体層中に配置され前記活性領域と電気的に接触する金属活性領域コンタクトと、
前記活性領域コンタクトの周囲の前記誘電体層中に配置された金属静電気放電保護構造とをそれぞれ形成するステップと、
)
)
${_ol}に従って形成され、
前記静電気放電保護構造は、前記誘電体層の表面上の電荷に対する直接的静電気放電路を形成するよう前記活性領域基板層と電気的に接触するものである、
半導体装置。
)_vbrv>
=cut
sub grupopen_cift_frm {
my ($m,$prog,$lihs,$sup,$lits) = shift->lpuc('grupopen_cift_frm',@_);$lits ||= $m->{lits};
return $m->dpop($prog) unless $sup;
return $m->dpop($prog) unless $lits;
my $frmt = $lits->{__frm};
FRMT: {
last if $frmt;
my $frmn = $m->grupvar($sup,'frm');
$frmt = $lihs->getstr($frmn);
};
return $m->dpop($prog) unless $frmt;
my $frmlr = $m->str2arb($frmt);
return $m->dpop($prog) unless 'ARRAY' eq ref $frmlr;
my @frml = @$frmlr;
return $m->dpop($prog) unless @frml;
shift @frml;
return $m->dpop($prog) unless @frml;
$frmt = $m->arb2str(\@frml,['/','+']);
$m->dpop1($prog,$frmt);
};
sub grupopen_pars_frm ($$;) { # read '@vrb' or '/proc+verbatim/proc+linioi/' into a $listref
my ($m,$prog,$lihs,$s) = shift->lpuc('grupopen_pars_frm',@_);
return $m->dpop($prog) unless $s;
return $m->dpop1($prog,$lihs->getstr($1)) if $s =~ m(\A\@(.*)\Z);
$s = $m->grupfill($s); # allow variables e.g. /+proc+ltximg+imgnom+tikz_luwh_${var}+/ file:/sig/oas/20/07/ecodX7/tra/wart/_lng.ecodX7_wart.txt::tikz_luwh_
$m->dpop1($prog,$s);
};
sub grupopen_stor_frm ($$$;) {
my ($m,$prog,$lihs,$nom,$frmt,$lits) = shift->lpuc('grupopen_stor_frm',@_);
return $m->dpop($prog) unless $nom;
return $m->dpop($prog) unless $frmt;
$lits ||= $m->{lits} || $m->pstop(funnovar => v => 'lits');
$lits->{__frm} = $frmt;
$lits->{__vars}->{_frm} = 1;
my $gvar = $m->grupvar($nom,'frm');
$lihs->putstr($gvar,$frmt,echo => $m->{debug}, typ => 'd');
$m->dpop1($prog,$frmt);
};
sub lits_put_atr {
my ($m,$prog,$nom,$val,$lits) = shift->ppuc('lits_put_atr',@_);$lits ||= $m->{lits} || $m->pstop(nolits => { n => $nom, v => $val });
$lits->{$nom} = $val;
}
sub lits_nov_atr {
my ($m,$prog,$nom,$val,$lits) = shift->ppuc('lits_put_atr',@_);$lits ||= $m->{lits} || $m->pstop(nolits => { n => $nom, v => $val });
$lits->{$nom} ||= $val;
}
sub grupopen_sup_put_fol { # register new node with the parent
my ($m,$prog,$sup,$fol,$ignor,$litverb) = shift->ppuc('grupopen_sup_put_fol',@_);
return $m->dpop($prog) unless $sup;
do { $m->{lits}->{__vrbs}->{$fol} = 1;$m->dpop1($prog,1) } if $litverb;
$m->lits_nov_atr(__fin => 2) if $ignor;
return $m->dpop1($prog,1) if $m->{lits}->{__fin} == 2;
$m->lits_nov_atr(__fin => 1); # kludge include_fin0 file:/phm/19/06/20/sig/_lng.phm_pub_sig190620.txt::h12r
$m->pstop(supnofols => s => $sup) unless 'ARRAY' eq ref $m->{lits}->{__fols};
return $m->Wpop0($prog, p => 'folinnfols', f => $fol, F => $m->{lits}->{__fols}, n => $sup) if $m->{lits}->{__folp}->{$fol};
push @{$m->{lits}->{__fols}}, $fol;
$m->{lits}->{__folp}->{$fol} = 1;
$m->dpop1($prog,1);
};
sub grupopen_varsput {
my ($m,$prog,$lihs,$optsr,$nom,$lits,@vars) = shift->tpuc('grupopen_varsput',@_);my %opts = $m->ref2hash($optsr);
foreach my $var (@vars) {
my $val = $lits->{'__'.$var};
next unless $val;
my $tvar = $m->grupvar($nom,$var);
$lihs->putstr($tvar => $val, echo => $m->{debug}, typ => 'd', %opts);
$lits->{__vars}->{'_'.$var} = 1;
};
$m->dpop1($prog,1);
};
sub grupopen_frmt_fols_set_lsts_hacs {
my ($m,$prog,$lihs,$optsr,$nom,$frmt,$lits,$fols,$ignor,$lits_ignor) = shift->tpuc('grupopen_frmt_fols_set_lsts_hacs',@_);
my %opts = $m->ref2hash($optsr);
$lits ||= $m->{lits} || $m->pstop(funnovar => 'v' => 'lits');
$lits->{__vars} ||= {};
$lits->{__lsts} ||= {};
$lits->{__hacs} ||= {};
$opts{litstag} = '' unless $opts{flng};
$m->grupopen_varsput($optsr,$nom,$lits,qw(nom fol sup num lvl frm));
$m->grupopen_stor_frm($lihs,$nom,$frmt,$lits) unless $ignor;
return $m->dpop($prog) if $lits_ignor;
$lits->{__fols} ||= [];
$lits->{__fols} = $fols if $fols;
$lits->{__num} = 0;
$m->dpop1($prog,1);
};
sub grupopen_init_lits { # even in ignored groups we need fields like __nom that tell us where we are
my ($m,$prog,$lits,$nom,$sup,$lvl,$fol,$ignor,$verbatim,$litverb) = shift->ppuc('grupopen_init_lits',@_);
$m->pstop(nusekt => n => $nom, l => $lits) unless $nom;
$lits->{__nom} = $nom;
$lits->{__sup} = $sup;
$lits->{__lvl} = $lvl;
$lits->{__fol} = $fol;
$lits->{__ignor} = $ignor;
$lits->{__verbatim} = $verbatim if defined $verbatim;
$lits->{__litverb} = $litverb if defined $litverb;
$m->dpop1($prog,$lits);
};
our %statsymp = ('!' => 1, '?' => 1);
=head4 ($ok,$nom2) = $m->grupopen(\%opts,$s): identify a group opening line $s that begins with parenthesis opener based on %opts
$s has been found to begin with '(' before we start.
=cut
sub grupopen {
my ($m,$prog,$lihs,$optsr,$s) = shift->tpuc('grupopen',@_);local $_ = $s;my %opts = $m->ref2hash($optsr);
my $rank_ignor = $opts{rank_ignor};
my $lits_ignor = $m->{lits}->{__ignor}; # ignore because grup is optional and a grup of same name was already evaluated
# TODO ignorfin: eliminate duplicate information between __ignor and __fin, clean up and document $m->{lits} data structure; file:/phm/19/06/10/sig/_lng.phm_pub_sig190610.txt::ignorfin
my $ignor = $rank_ignor || $lits_ignor;
$opts{rank_ignor} = $ignor;
my $sep = '';
my $fol0 = '';
my $specsekt = ''; # addons to grup e.g. '<uwarn(notgrupopen => l => $_, k => $kloz ? ')' : '');
return $m->dpop($prog);
};
my ($litverb, $verbatim) = (); # undefined
# $m->grupopen_get_specsekt; # file:/adv/perl/A2E/OLD/Tmplfil.old::grupopen_get_specsekt
$_ = $rest;
my $sup = $m->{lits}->{__nom};
my $sup_verbatim = $m->grupvars_getstr($lihs,__verbatim => $sup);
return $m->dpop($prog) if $sup_verbatim;
$m->ustop('sektnomnil') unless $fol0 or $sup;
my $lvl = $sup ? $m->{lits}->{__lvl} : 0;$lvl++;$m->{__flvl}++;
my ($nom, $fol) = $m->grupopen_supfol2nomfol($lihs, $sup, $fol0);
my $val = $lihs->getstr($nom); # grupopen_nomfol
$m->uwarn(regrup => n => $nom, v => $val) if $val;
OLDSUP: {
last unless $m->{nom2lits}->{$nom} and $sup;
my $oldsup = $m->{nom2lits}->{$nom}->{__sup} || '0O0';
last if $sup eq $oldsup;
$m->ustop('trying to insert group %n under %s but it is already under %o', n => $nom, s => $sup, o => $oldsup);
};
my $sup1 = $sup;
while ($sup1) { # check for circularity: $nom must not be present among parents
$m->ustop(nomcirkl => n => $nom) if $nom eq $sup1;
$sup1 = $m->{nom2lits}->{$sup1}->{__sup};
};
my $fin = 0;
my $stat = 0;
my $lits = $m->{nom2lits}->{$nom} || {};
$lits->{__fsup} = 1 if $lits->{__sup} and not $sup;
$m->pstop(nomlits => n => $nom, l => $lits) unless 'HASH' eq ref $lits;
my $initlitsfols = sub {
$m->lits_put_atr(__fin => 0, $lits); # group just starting, not finished
$lits->{__lini} = 0; # line number as read from multilingual source file, where only every other line is read into the tree with a number $lits->{__num}
$lits->{__fols} ||= [];$lits->{__folp} = {};
$lits->{__fols};
};
my $fols = &$initlitsfols($lits);
my $grupopen_args = sub { # parse all arguments of the opener line, up to a possible closing bracket
my $next = shift;
return unless $next;
my $ignor = shift;
return if $ignor;
my $kloz = shift;
my ($sep, @args) = $m->textsep2seplist(substr($next,1),substr($next,0,1));
# $sep is space or '|', $next may be C or C<@vrb>,
$next = shift @args;
my $frmt = '';
unless ($statsymp{$next}) { # 150210 added $ignor
$frmt = $next;
$next = shift @args;
};
return $frmt unless $next;
# following @args used to be ('!', '+papri+europarl0309+...+') but are now unused
$next = shift @args;
# last unless $next;
my $goto_korp = sub {
return unless $next =~ m(\A[?!]\Z);
FIN: {
do { $m->lits_put_atr(__fin => 2);last } if $ignor;
NEXT: {
if ('?' eq $next) { $lits->{__fin} = @{$lits->{__fols}} ? 2 : 1;last };
if ('!' eq $next) { $lits->{__fin} = 1;@{$lits->{__fols}} = ();%{$m->{$lits->{__folp}}} = ();last };
};
};
return shift @args;
};
$next = &$goto_korp($next,@args);
return $frmt unless $next;
$m->ustop(finkloz => n => $next) unless $kloz;
$m->kopifols($optsr,$next,$nom); # OLD: my $elgrup = sub { $lits->{__fin} ||= 1; ($lits, $fols) = $m->grupopen_elgrup($nom, $next, $lits, $fols); }; &$elgrup unless $ignor or !$kloz or $lits->{__fin} == 2;
return $frmt;
};
my $frmt = &$grupopen_args($_,$ignor,$kloz);
$frmt = $m->grupopen_pars_frm($lihs,$frmt) if $frmt;
$frmt ||= $m->grupopen_cift_frm($lihs,$sup);
my $fol_lits_setup = sub {
$m->grupopen_init_lits($lits,$nom,$sup,$lvl,$fol,$ignor,$verbatim,$litverb);
return if $rank_ignor; # in ignored groups we do not care about subgroups and register exported variables only with their absolute names as done in tmplini_setnomval
$m->grupopen_frmt_fols_set_lsts_hacs($optsr,$nom,$frmt,$lits,$fols,$ignor,$lits_ignor);
};
&$fol_lits_setup;
$m->grupopen_sup_put_fol($sup,$fol,$ignor,$litverb);
$m->{nom2lits}->{$nom} = $lits;
$m->{lits} = $lits;
# $m->grupopen_jungils($nom, $frmlr, $lits) unless $ignor;
if ($kloz) {
($nom) = $m->grupkloz_setlits($optsr,$nom);
} else { # proper opening
$m->pstop(setnusekt => l => $lits) unless $lits->{__nom};
$m->set_grupvars($nom,%opts) unless $rank_ignor;
};
$m->dpop($prog,1,$nom);
}; #grupopen
=head4 Function grupkloz_setvars
Synopsis
args := nom
rets := ok
Set some textchunks that carry information about the current group, particularly its components and local variables of various types, so that the group can be reconstructed later. The information stored here doesn't comprise the variable values, which are stored by tmplini_setnmomval earlier.
This must be done both when a ')' line is encountered and when a group opener line ends with a closer.
m->{lits} must previously have been set to contain the collected metainfo of
the node that is ending here.
$klozp :: whether we are preparing to close the whole grup (1) or only the attribute section (0);
TODO: KLOZP: should't this be done on entry into grupkorp ? the klozp part is done on grup closing, the rest on transition to body
=cut
sub grupkloz_setvars {
my ($m,$prog,$lihs,$optsr,$nom,$klozp) = shift->tpuc('grupkloz_setvars',@_);my %opts = $m->ref2hash($optsr);
my $verbose = $m->pvar(verbose => 1);
if ($klozp) { delete $m->{lits}->{'__'.$_} for qw(fin lini) };
$opts{dyna} = 1;
$opts{litstag} = $opts{flng} && $opts{litstag};
$opts{echo} ||= $verbose;
$opts{typ} = 'd';
$m->kopilits(\%opts,$nom); # kopilits_novopts
STAT: {
last unless $klozp;
last unless $m->{lits}->{__stat};
my $var = $m->grupvar($nom, 'stat');
$lihs->putstr($var => 1, %opts);
delete $m->{lits}->{__stat};
};
my @vars = $klozp ? qw(fols) : qw(vars lsts hacs);
foreach my $typ (@vars) {
my $var = $m->grupvar($nom, $typ); # olgmV9__fols
my $ref = $m->{lits}->{'__'.$typ}; # __fols => \%fols
my $typnom = $typ eq 'fols' ? 'ARRAY' : 'HASH';
next if $typnom ne ref $ref;
my @lst = $typnom eq 'ARRAY' ? @$ref : keys %$ref;
next if !@lst; # neputnonfols: 不寫空的 __fols __vars 等
my $slst = $m->arb2str(\@lst,['+']);
#
# $lihs->{var2typ}->{$var}->{d} = 1;
# $lihs->{typ2var}->{d}->{$var} = 1;
#
$lihs->putstr($var => $slst, %opts);
};
# file:/adv/perl/A2E/OLD/Tmplfil.old::GRUPKLOZ_SETVRBS
$m->dpop1($prog,1);
};
=head4 Function grupkloz
Deal with a line consisting of a closing bracket, optionally followed by the name of the group to be closed by it, e.g. the lines after the ... content:
(vrb<
(p2pat
(
....
)
)p2pat
)_vrb>
This has been complicated by verbatim mode.
with EBNF synopsis
args := ignor, lini
rets := ok, nom
lini :: the suspicious line, starting with closing bracket, without final LF
sup := the name of the group that we are in now
lits :: a hashref of known attributes of our group, also stored in $m->{lits};
ok :: Was found to be a group closer and not just a verbatim bracket character
nom :: the group that we are returning to, nil if top level
=cut
sub grupkloz {
my ($m,$prog,$lihs,$optsr,$s) = shift->tpuc('grupkloz',@_);local $_ = $s;my %opts = $m->ref2hash($optsr);
my $rank_ignor = $opts{rank_ignor}; # ignore because of low rank/priority of file
my $fol = $m->{lits}->{__fol};
$_ = substr $_, 1; # ')~m' => '~m'
my $nom = $m->{lits}->{__nom};
my $verbatim = $m->grupvars_getstr($lihs,__verbatim => $nom); # we are in a verbatim group where ordinary closers are ignored but stuff like ')_vrb>' is not.
FOL_ARG: { #Deal with cases where there is trailing matter after the closing bracket. All verbatim group closers must be named.
last unless $_;
my ($fol_arg,$verbatim_kloz) = m(\A(\~?\w+)(\>?)\Z);
return $m->Wpop0($prog,u => 'This looks dangerously similar to a group closing bracket: %l', l => $_) unless $fol_arg;
VERBATIM: { # Make sure that if a verbatim group closer such as 'vrb>' was found then it matches the verbatim group that was last opened
do { $m->ustop('Attempting to close inexistent verbatim group %f', f => $fol_arg) if $verbatim_kloz;last } unless $verbatim;
return $m->dpop($prog,0,$nom) unless $verbatim_kloz; # leave without closing if we are in verbatim mode without a proper verbatim closer; verbatim groups are meant to talk about all sorts of grammatical errors so we quit here.
last if $fol_arg eq $verbatim; # check validity of closer
$m->ustop(q{Attempting to close verbatim group '%f' but we are in '%v'}, f => $fol_arg, v => $verbatim);
};
last if $fol_arg eq $fol;
$m->ustop('encountered closer for %c but we are in %f aka %n', c => $fol_arg, f => $fol, n => $nom);
};
# now properly close the group, be it normal or verbatim, return $nom of parent group
($nom) = $m->grupkloz_setlits($optsr,$nom);
$m->{__flvl}--;
$m->dpop($prog,1,$nom);
};
=head5 Subfunction grupkloz_setlits
Heart piece of grupkloz, close a group without parsing a closer line.
args := nom, rank_ignor?
rets := sup, lits
lits := hashref
nom is the name of the textchunk that we are closing.
We now leave this section, storing needed info, and set our current textchunk info m->{lits} to its parent.
This is a subfunction of grupkloz that is also needed by grupopen in cases where a section closes on the same line where it opens.
=cut
sub grupkloz_setlits {
my ($m,$prog,$lihs,$optsr,$nom) = shift->tpuc('grupkloz_setlits',@_);my %opts = $m->ref2hash($optsr);
my $rank_ignor = $opts{rank_ignor};
my $lang = $opts{lang} || $m->pvar(lang => 1);
$m->pstop('need lits hashref for node %n', n => $nom) unless $m->{lits} and 'HASH' eq ref $m->{lits};
$m->ustop('encountered closer that was not preceded by an opener') unless $nom;
$m->grupkloz_setvars($optsr,$nom,1) unless $rank_ignor;
$m->{nom2lits}->{$nom} ||= $m->{lits}; # 單語改動不登錄; 信息可省、用 A2E::Grup 將無
$m->{nom2gvars}->{$nom} = undef; # at least this dead weight can be discarded
my $sup = $m->{lits}->{__sup};
my $fsup = $m->{lits}->{__fsup};
if ($sup and not $fsup) {
$m->pwarn('unregistered parent node %p of node %n', p => $sup, n => $nom) unless $m->{nom2lits}->{$sup};
$m->{lits} = $m->{nom2lits}->{$sup}; # nom2lits_kloz
$m->pwarn('parent node %p of node %n does not know itself, we are outside all groups', p => $sup, n => $nom) unless $m->{lits}->{__nom};
$m->{lits}->{__lini} = 0; # ensure that multilingual source with @slngs starts afresh
} else {
$m->{lits}->{__fsup} = 0 if $fsup;
$m->{lits} = {}
};
$m->dpop1($prog,$sup);
};
=head4 Function gruplini
Assign a line to the next textchunk.
The line is normally a mere leaf without its own $m->{lits} struct.
In the case of GLINGRUP (cf below) the line itself becomes a $m->{lits} struct with leaf children
GLINGRUP:
Assign parts of a line to the next textchunk hierarchy. E.g.
|John|25|
|Jane|24|
should mean the same as
(
John
25
)
(
Jane
24
)
Processing depth should depend on a variable C<_lvlmax>
=head5 Subroutine gruplinisplit
Try to split lines and store result into @flds for processing as a group.
args := val, lvlmax, frm0+
rets := lvlmax, fld+
val => 'Odi et amo. Quare id faciam? Fortasse requiris. Nescio! Sed fieri sentio. Et excrucior!'
lvlmax => 1
lvlmax :: level up to which structured expressions like ||nom|+a+b+c||klav|+c+d+e| are to be split if no other operator than lvlmax is given. This can be obtained both from outside the function and from frm0+ and thus must be handed back in rets.
frm0+ => +proc+linioi_spi+lrsplit+sentsplit+
frm0 :: list of which the last to elements are an operator and a value, see operators below.
fld+ => |Odi et amo.|Quare id faciam?|Fortasse requiris.|Nescio!|Sed fieri sentio.|Et excrucior.|
Use operators
split
match
lsplit
rsplit
lrsplit
lvlmax
which can be specified at the end of the formatter information of one node, e.g.
sentsplit = ([.!?:])\s+([[:upper:]])
@sent = /proc+linioi_spi+lrsplit+sentsplit/
(verse @sent
Odi et amo. Quare id faciam? Fortasse requiris. Nescio! Sed fieri sentio. Et excrucior!
)
This will split the line into a group of textchunks instead of treating it as as a single textchunk.
The work is not done by the formatter.
The formatter is receiving the C<+lrsplit+sentsplit+> arguments but we may also later decide to suppress these pseudo-formatter-arguments after splitting is done.
If separation is not successful, return nothing, not even lvlmax.
=cut
our %frml_verb_tab = ();$frml_verb_tab{$_} = 1 for 'proc', 'vok';
# lvlmax treated as a special case, not true but only defined
our %splitil_tab = ();$splitil_tab{$_} = 1 for 'split', 'match', 'lsplit', 'rsplit', 'lrsplit';$splitil_tab{lvlmax} = 0;
sub gruplinisplit {
my ($m,$prog,$lihs,$optsr,$val,$lvlmax,@frmtup) = shift->tpuc('gruplinisplit',@_);
# val => 'Odi et amo. Quare id faciam? Fortasse requiris. Nescio! Sed fieri sentio. Et excrucior!'
# lvlmax => 1
# @frmtup => ('proc', 'linioi', 'lrsplit', 'splitsent')
do { $m->decho('no formatter info available for text %v', v => $val);return $m->dpop($prog) } unless @frmtup;
my $ftval = '';
my $ftnom = '';
my $splitil_p = 0; # found parameter is a regex-based splitter with value 1 in %splitil_tab
my $splitil_defp = 0; # found parameter is a splitter registered in %splitil_tab
my @frmtup_rest = (); # unused formatter parameters
$m->ustop('uneven number %d of formatter arguments in %f', d => (1 + $#frmtup), f => $m->koniug_et(@frmtup)) unless 1 == $#frmtup % 2;
FTNOMVALS: {
NOOPT: {
last if 1 < $#frmtup; # more than two elements in the formatter commandline, we can go on
$m->uwarn('invalid formatter verb %v', v => $frmtup[0]) unless $frml_verb_tab{$frmtup[0]};
last FTNOMVALS;
};
$ftval = pop @frmtup;
$ftnom = pop @frmtup;
DEFP: {
$splitil_p = $splitil_tab{$ftnom};
$splitil_defp = defined $splitil_p;
last unless $splitil_defp;
last FTNOMVALS;
}
push @frmtup_rest, $ftnom, $ftval;
redo FTNOMVALS;
};
return $m->dpop($prog) unless $splitil_p;
push @frmtup, @frmtup_rest;
my $frmer = [ @frmtup ];
my @flds = ();
SPLITIL: { # use regex variables specified with formatter pseudo-arguments 'lrsplit' etc
last unless $splitil_p;
my $regex = $lihs->getstr($ftval);
$m->ustop('unknown regex variable %v', v => $ftval) unless $regex;
TRY: {
MATCH: {
last unless $ftnom eq 'match';
(@flds) = $val =~ m($regex);
last TRY;
};
SPLIT: {
last unless $ftnom eq 'split';
(@flds) = split m($regex), $val;
last TRY;
};
LSPLIT: { # split with a splitter containing a matching suffix part that is appended to the left side element
# useful for splitting sentences with ([.!?])\s+
last unless $ftnom eq 'lsplit';
my ($fld, @rest) = split m($regex), $val;
FLDS: {
last unless $fld;
while (@rest) {
$fld .= shift @rest;
push @flds, $fld;
$fld = shift @rest;
};
last unless $fld;
push @flds, $fld;
}; # JOIN;
last TRY;
}; #LSPLIT
RSPLIT: { # split with a splitter containing a matching prefix part that is prepended to the right side element
# added for symmetry with LSPLIT, no use envisaged so far
last unless $ftnom eq 'rsplit';
my ($fld, @rest) = split m($regex), $val;
FLDS: {
last unless $fld;
push @flds, $fld;
while (@rest) {
$fld = shift @rest;
$fld .= shift @rest;
push @flds, $fld;
};
};
last TRY;
}; #RSPLIT
LRSPLIT: { # split with a splitter containing a matching prefix part that is appended to the left and one that is prepended to the right side element
last unless $ftnom eq 'lrsplit';
my ($fld, @rest) = split m($regex), $val;
FLDS: {
last unless $fld;
while (@rest) {
$fld .= shift @rest;
push @flds, $fld;
$fld = shift @rest;
$fld .= shift @rest;
};
last unless $fld;
push @flds, $fld;
};
last TRY;
}; #LRSPLIT
$m->pstop('invalid line separator frm0nom %n', n => $ftnom);
}; #TRY
$m->ustop('no records found by %n %v on line %l', n => $ftnom, v => $ftval, l => $val) unless @flds;
return $m->dpop($prog,$lvlmax,$frmer,@flds);
};
LVLMAX: {
FT: {
last unless $ftnom eq 'lvlmax';
$m->pstop('lvlmax %l must be integer between 1 and 3 but is %v', l => $ftval, v => $val) unless $ftval =~ m(\A[1-3]\Z);
$lvlmax = $ftval;
};
last unless $lvlmax; # split only if lvlmax is present and above zero.
my $sep;
($sep, @flds) = $m->textsep2seplist($val);
$m->pstop('no records found by separator %x on line %v', x => $sep, v => $val) unless @flds;
return $m->dpop($prog, $lvlmax, @flds);
};
$m->dpop($prog);
};
=head5 Subroutine gruplini_nosplit
Store line into variable without splitting.
If needed evaluate the line.
Do not store in memory but in file only, thus making it inaccessible to template except indirectly via vmethods like litscat
Switch linp instructs putstr to do this, cf file:/adv/perl/A2E/Lihs.pm::linp
=cut
sub gruplini_nosplit { # just store as one line without splitting
my ($m,$prog,$lihs,$optsr,$nom,$val,$lits) = shift->tpuc('gruplini_nosplit',@_);my %opts = $m->ref2hash($optsr);$lits ||= $m->{lits};
my $verbose = $m->pvar(verbose => 1);
$val = $m->grupfill($val, lihs => $lihs) if $lits->{__stat};
$lihs->putstr($nom => $val, typ => 't', echo => $verbose, linp => 1, %opts);
$m->dpop1($prog,$val);
};
=head5 my $ok = gruplini_lang_eq_slng_p
Whether the current line in the master source text belongs to our current monolingual version.
If $ok is 0, the line is ignored
If $ok is 1, the line is recorded in the current language $ll vocabulary .lits/l.$ll/$nom
If $ok is 2, the line is recorded in the master soruce vocabulary .lits/$nom
=cut
sub gruplini_lang_eq_slng_p {
my ($m,$prog,$lihs,$sup,$lang,$flng) = shift->lpuc('gruplini_lang_eq_slng_p',@_);
my $lini = $m->{lits}->{__lini}++;
my $lini0 = $m->{lits}->{__lini0}++; # glini_lang_eq_flng
FLNG: { # glini_flng: special treatment for monolingual source files
last unless $flng;
my $ok = $flng eq $lang;
return $m->dpop1($prog,$ok);
};
my @slngs = $m->grupvars_getlst($lihs, slngs => $sup); # ('zh','de')
my $LX = $m->grupvars_getval($lihs, LX => $sup) || 'LX'; # local LinguaFranca
my $nlngs = scalar @slngs;
my $ll2ok = sub { my $ll = shift;if (grep { $_ eq $ll } $lang, '1LL') { 1 } elsif ($LX eq $ll) { 2 } };
NLNGS: { # in monolingual doc we do not need to check
last if $nlngs > 1;
my $ok = &$ll2ok($slngs[0]);
return $m->dpop1($prog,$ok);
};
SLNG1: { # directive slng1 make the current field (lit) monolingual. Rules with special enumerated arguments can be used to make some fields of a table monolingual
# e.g.: slng1 = $(case ${2},1,[cd],0)
# ${1} is current fol, e.g. '_a_c', in which case ${2} is 'a_c', ${3} is 'a' and ${4} is 'c'
my $slng1 = $m->grupvars_getval($lihs, slng1 => $sup); # OLD 200921: my $slng1 = $m->grupvars_getval($lihs, slng1 => 0);
last if ! defined $slng1;
# slng1 may be a complex expression e.g. $(case|${2}|0|(?:num|kap)|1)
my $fol1 = $m->{lits}->{__fol}; # _kap_val
my ($fol2) = $fol1 =~ m(\A\_?([a-z]\w*)\Z); # kap_val
my @span = split '_', $fol2; # qw/kap val/
$slng1 = $m->{sarb}->val_args_call($slng1,undef, $fol1, $fol2, @span); # ${1} => _kap_val, ${2} => kap_val, ${3} => kap, ${4} => val
last if ! $slng1;
my $linilang_div = 1+ int $lini / $nlngs; # line number assuming we are operating in mutilingual mode;
last if $slng1 > $linilang_div; # start with multilingual lines: file:/phm/19/06/24/sig/_lng.phm_pub_sig190624.txt::linilang
$m->{lits}->{__lini0} = 0;
return $m->dpop1($prog,1);
};
my $linilang_mod = $lini0 % $nlngs;
my $linilang = $slngs[$linilang_mod];
my $ok = &$ll2ok($linilang);
$m->decho('ignoring source language %l other than %L', l => $linilang, L => $lang) unless $ok;
$m->dpop1($prog,$ok);
};
sub gruplini {
my ($m,$prog,$lihs,$optsr,$val) = shift->tpuc('gruplini',@_);my %opts = $m->ref2hash($optsr);
my $sup = $m->{lits}->{__nom};
IGNORP: {
my $ignorp = $m->grupvars_getstr($lihs, ignorgrup => $sup);
last if ! $ignorp;
return $m->dpop($prog);
};
$m->pstop(nogruplini => 0) if !$sup;
my $lang = $m->pvar(lang => 0);
my $kontp = 1; # do move the counter in upcoming set_nom_fols
# enable conditional multiline multilinguality, e.g. "[]\t20V\n[zh] 20伏\n"
# when a ltrx expression has [.*] followed by space other than ' ' (e.g. ' ', "\t") we parse another line
my $ltrxp = 0; # do not treat as selected by ltrxpars (but rather just cycle $lang through @slngs)
my $glngp = 0;
SLNGP: {
LTRXPARS: { # parse language selector marks in source text e.g. ^[]
# lang sel regex, first use file:/sig/oas/20/07/ecodX7/tra/wart/_lng.ecodX7_wart.txt
my $ltrx = $lihs->getval('ltrx');
$ltrx = $ltrx ? qr($ltrx) : qr(\A\[(.*)\](\s+)(.*)\Z);
my ($lrx,$spc,$sv) = $val =~ m($ltrx);
last if ! $sv; # no language selector found, go on cycling through @slngs
$val = $sv;
if (!$lrx) {
$ltrxp = 1;
} elsif ($lrx =~ m(\A\w+\Z)) {
$ltrxp = $lang eq $lrx;
} elsif ($lrx =~ m(\A\w.*\w\Z)) {
my @ll = split m(\W), $lrx;
$ltrxp = grep { $_ eq $lang } @ll;
} else {
$lrx = qr(\A$lrx\Z); # /\A.*\Z/
$ltrxp = $lang =~ m($lrx);
};
return $m->dpop($prog) if ! $ltrxp; # language selector match e.g. [zh] resulted in 0, nothing to read here, leave
last unless $ltrxp;
$kontp = $spc eq ' ';
$m->{lits}->{__lini0} = 0;
last SLNGP;
};
$glngp = $m->gruplini_lang_eq_slng_p($lihs,$sup,$lang,$optsr->{flng}); # gruplini_glngp
last if $glngp;
return $m->dpop($prog);
};
$opts{flng} ||= $lang if $glngp == 1; # not for LX;
my $set_nom_fols = sub {
my $num = ++$m->{lits}->{__num};
my $fol = $m->supnum2fol($sup,$num);
my $nom = $sup . $fol;
$fol = '~' . $fol; # '~' notation signifies suffixness
if ($m->{lits}->{__folp}->{$fol}) {
$m->uwarn(folinnfols => f => $fol, F => $m->{lits}->{__fols}, n => $nom);
} else {
push @{$m->{lits}->{__fols}}, $fol;$m->{lits}->{__folp}->{$fol} = 1;
};
return $nom, $fol;
};
my $nom = '';
my $fol = '';
KONTP: {
last unless $kontp;
($nom, $fol) = &$set_nom_fols;
last unless $ltrxp; # persistent storage needed to save nom and fol for trailing members of ltrxpars i.e. "[] ...\n[zh]\t..." linegroup
($m->{slits}->{__nom}, $m->{slits}->{__fol}) = ($nom, $fol); # store subbranch info in slits, separate from lits;
};
NKONTP: {
last if $kontp; # from here on we are in a trailing member of ltrxpars linegroup
($nom, $fol) = ($m->{slits}->{__nom}, $m->{slits}->{__fol}); # read prestored subbranch info
};
NOMFOLCHK: { # 201001 help debug new LTRXPARS/KONTP/NKONTP syntax
last if $nom and $fol;
$m->pstop('unable to assign nom and fol to in grup %n to line reading %v', n => $m->{lits}->{__nom}, v => $val);
};
my $glingrup = sub { # treat line as line or as something to split into a group
# Decide whether each line is really a single line or a group that needs to be split into chunks by a given splitter, and process accordingly.
# cf old stuff at file:/phm/15/02/07/sig/old_glingrup.pl
my @flds = ();
my $get_frmt = sub {
# block nom7frmt: read special textchunk variable like @top_frm, @ul_frm or fallback @frm
# Use value of this variable, which typically refers to simple formatter table consisting of one level of lines such as C<@frm = /proc+linioi_spi/>.
my $frmt = shift;
return $frmt if $frmt;
FOL2FRMT: {
last if !$fol or $fol =~ m(\A\~\d);
$m->vecho(nofrml => n => $nom);
my $frmnom = $nom . '_frm';
$m->decho(frmnom => f => $frmnom);
$frmt = $lihs->getstr($frmnom);
return $frmt if $frmt;
};
VAR2FRMT: {
$frmt = $lihs->getstr('ll');
return $frmt if $frmt;
};
$m->ustop(gnofrml => g => $nom);
};
my $frmt = &$get_frmt($m->{lits}->{__frm});
my $frmlr = $m->str2arb($frmt);
my @frml = $m->ref2list($frmlr);
$m->pstop(glingruperef => n => $nom) if !@frml;
shift @frml; # ([ 'proc', 'linioi', 'lrsplit', 'sentsplit' ], [ 'call', 'quote' ])
my $setfrmlr = sub {
return if ! @frml;
my $lvlmax = $m->{lits}->{__lvlmax};
$lvlmax-- if $lvlmax;
my $frmer = $frml[0]; # => [ 'proc', 'linioi', 'lrsplit', 'sentsplit' ];
$m->pstop(badfrmer => r => $frmer, t => \@frml) unless 'ARRAY' eq ref $frmer;
($lvlmax,$frmer,@flds) = $m->gruplinisplit(\%opts,$val,$lvlmax,@$frmer); # split only if told to so so by $frmer
return if ! @flds;
$frml[0] = $frmer; # remove trailing linesplitter pseudo-arguments from frml (?)
(\@frml, $lvlmax, @flds);
};
($frmlr,my $lvlmax,@flds) = &$setfrmlr;
return $m->gruplini_nosplit(\%opts,$nom,$val) if ! $frmlr;
my $grupopen = sub {
$m->{lits} = $m->{nom2lits}->{$nom} || {};
$m->pstop(nomlits => n => $nom, l => $m->{lits}) unless 'HASH' eq ref $m->{lits};
$m->lits_put_atr(__fin => 0); # definition section opening
$m->{lits}->{__lini} = 0;
$m->{lits}->{__num} = 0;
$m->{lits}->{__nom} = $nom;
$m->{lits}->{__sup} = $sup;
$m->{lits}->{__lvlmax} = $lvlmax if $lvlmax;
$m->grupopen_frmt_fols_set_lsts_hacs($nom,$frmt,\%opts);
};
&$grupopen;
my $subgrup = sub {
foreach my $fld (@flds) { $m->gruplini($optsr,$fld) };
1;
};
&$subgrup;
my $grupkloz = sub {
$m->lits_put_atr(__fin => 1); # definition section closed
($nom) = $m->grupkloz_setlits($optsr,$nom);
1;
};
&$grupkloz;
};
&$glingrup;
$m->dpop1($prog,$nom);
};
=head4 Function lits_tfol2nom
Derive the absolute lit name from the relative/leaf form, especially in trees like
(p2pat
(konfus proc+titenumlist
lab = Verwirrung
=0 = Verwirrend erscheint insbesondere,
+ = dass die Involvierung von externen Freiwilligen den Geheimnisschutz verbessern soll
)
)
when invoked with '+*0', based on available $m->{lits} tree, return 'p2pat_konfus0'.
Synopsis
args := tfol, lits?
rets := nom, fol, typ
tfol => '@hi'
tfol :: prefixed leaf for which to derive absolute name; returned version contains resulting fixed value '=1' instead of '+' or '-'
typ => '@'
fol => 'hi'
fol :: leaf without prefix
fol => =0 ; mov => =, fol => 0
fol => + ; mov => +, fol =>
fol => _tit; mov =>, fol = _tit
fol => +_des; mov => +, fol = _des
lits :: hierarchy tree info to use, defaulting to $m->{lits}
nom :: textchunk name
nom => p2pat_konfus0
typ => '@'
typ :: variable type prefix, @ for list, % for hash
This function interprets prefixes like '+' and '_' in order to decide how to build the variable name so that the function as sketched in dok:adv_pub_litscat1004.
dont confuse with lit_fol2om
=cut
sub lits_tfol2nom {
my ($m,$prog,$s,$lits) = shift->ppuc('lits_tfol2nom',@_);
my ($typ, $fol) = $s =~ m(\A([@%]?)(\w*)\Z);
$lits ||= $m->{lits};
my $sup = $lits->{__nom};
my $nom = $fol;
$typ ||= '$';
return $m->dpop($prog,$nom,$sup,$fol,$typ) if !$sup;
$nom = $sup . '_' . $fol;
$m->dpop($prog,$nom,$sup,$fol,$typ);
}
=head4 Function grupkorp
Move from the header to the body of a group in response to '!' or '?' which is given as argument.
Just set the state for processing of text body lines which is done later in gruplini.
=cut
sub grupkorp ($+$;) {
my ($m,$prog,$lihs,$optsr,$fin,$stat) = shift->tpuc('grupkorp',@_);my %opts = $m->ref2hash($optsr);my $gvars = $optsr->{gvars} || $m->{grupvars};
my $ignor = $opts{rank_ignor} || $m->{lits}->{__ignor};
$fin ||= ''; # '?' or '!'
$stat ||= ''; # ':' or ''
my $nom = $m->{lits}->{__nom};
$m->ustop('found body opening symbol line %f outside a group', f => $fin) unless $nom;
my $ll = $m->pvar(lang => 1);
SETLITSFIN:{
# __fin signals that body lines are to be read rather than ignored
$m->pstop('nolitsfols') if 'ARRAY' ne ref $m->{lits}->{__fols}; # nofolsstop
my $nfin = do { if ($ignor or @{$m->{lits}->{__fols}} and $fin eq '?') { $m->{lits}->{__ignor} = 1;2 } elsif ($fin eq '!') { @{$m->{lits}->{__fols}} = ();1 } else { 0 } };
$m->lits_put_atr(__fin => $nfin);
$m->lits_put_atr(__stat => 1) if $stat eq ':';
$m->lits_put_atr(__lini => 0);
};
$m->grupkloz_setvars($optsr,$nom,0);
INCLUDE: {
last unless $m->{lits}->{__vars}->{include}; # avoid reinvocaton by lower levels: file:/phm/18/09/02/sig/_lng.phm_pub_sig180902.txt
my $fayl = $gvars->{include};
last unless $fayl;
$gvars->{include} = undef;
# delete $m->{grupvars}->{include};delete $m->{lits}->{include}; # kludge /phm/18/09/02/sig/_lng.phm_pub_sig180902.txt
$m->uwarn(fginclude => g => $nom, f => $fayl);
$m->lits_put_atr(__fin => 0); # file:/phm/19/06/19/sig/_lng.phm_pub_sig190619.txt::ifin include_fin0: allow included document to begin with assignments
$m->riid_tmplvars_fayl($fayl, sup => $nom, insistp => 1, %opts);
return $m->dpop1($prog,1);
};
$m->dpop1($prog,1);
};
=head4 Function debug_litnom
In grupsynt, switch on debugging if current textchunk is one of DEBUG_LITNOMS.
=cut
sub debug_litnom {
my ($m,$prog,$lnom) = shift->ppuc('debug_litnom',@_);
return $m->dpop($prog) unless $m->{debug_litnoms};
TRY: {
OFF2ON: {
last if $m->{debug};
last unless grep { $_ eq $lnom } @{$m->{debug_litnoms}};
$m->{debug} = $lnom;
last TRY;
};
ON2OFF: {
last unless $m->{debug} eq $lnom;
last if grep { $lnom =~ m(\A\_) } @{$m->{debug_litnoms}};
$m->{debug} = '';
last TRY;
};
};
$m->dpop1($prog,$m->{debug});
};
=head4 $m->grupsynt(\%opts,$lini,$s) => $ok
Check whether we have group related syntax and if so process it and return true.
Analogous to tmplini_kondsynt.
args := lini, lini_nokoment, ignor, opts
rets := ok
lini :: whole line
lini_nokoment :: line with everything after '#' removed
ignor :: we are in a low-rank unexport-level file e.g. a @lng.*.txt files of a superordinate directory and therefore ignore everything that is in a group except for variable assignments marked with C
opts :: options for tmplini et al which are passed down all the way to $lihs->putstr/getval
=cut
our $orglvl = 0; # 從此以上不再使用文段括弧而唯靠組織模式記法 file:/phm/22/07/15/sig/_lng.phm_pub_sig220715.txt::ankvsnom
undef $orglvl; # 整數型但平時無値
sub grupsynt {
my ($m,$prog,$lihs,$optsr,$lini,$s) = shift->tpuc('grupsynt',@_);my %opts = $m->ref2hash($optsr);local $_ = $s;
my $rank_ignor = $opts{rank_ignor};
my $nom = $m->{lits}->{__nom};
my $fol = $m->{lits}->{__fol};
NONKORP: { # Block Nonkorp
# We are not yet in a text body
last if ! $nom; # without $nom we are outside any group anyway
last if $m->{lits}->{__fin} and not ($orglvl && m(\A\*)); # with __fin we are already in a body and dont need to transit to one, but orgtitpfx1 could mark an end file:/phm/22/07/15/sig/_lng.phm_pub_sig220715.txt::ankvsnom
NOMVAL: { # set an attribute in normal syntax
my @nomval = m($m->{qre}->{setnomval});
last if ! @nomval;
$m->tmplini_setnomval($optsr,@nomval);
return $m->dpop1($prog,1);
};
ORGTIT: { # process org-mode title line e.g. "** DONE <> FFP2-Masken :covid19"
my $get_ank_tit = sub { # check possible org-style title line syntax, extract anchor $ank and title $tit
my ($pfx, $tut) = m(\A(\*+)\s+(\S.*)\s*\Z); # $tut is whole headline with or without anchor <<$ank>>
return unless $tut;
my ($tds, $ank, $tit) = $tut =~ m(\A(TODO|DONE|)\s*\<\<(\w+)\>\>\s*(.*)\Z);
TUTANKTIT: { # [[file:/phm/22/08/10/sig/_lng.phm_pub_sig220810.txt::tutanktit][允許組織模式中簡略標題]]
last if $ank;
$m->ustop('Fehlender Anker in Org-Sektionstitel %t', t => $tut) unless $tut =~ m(\A\w+\Z);
$ank = $tut;$tit = $tut;
};
my $lp = length $pfx;
ANKVSNOM: { # 不帶括弧而光以組織模式記法開啟新文段 file:/phm/22/07/15/sig/_lng.phm_pub_sig220715.txt::ankvsnom
last if $nom eq $ank or $fol eq $ank;
$m->pwarn(ankvsnom => a => $ank, n => $nom);
GRUPKORPKLOZ: { # file:/phm/22/08/01/sig/_lng.phm_pub_sig220801.txt::sektrek
SUPGRPKORPKLOZ: { last unless $m->{lits}->{__lvl} > $lp; # 回到上層
while ($m->{lits}->{__lvl} > $lp) {
$m->grupkorp($optsr, '!') unless $m->{lits}->{__fin};
$m->grupkloz($optsr,')');
}
last GRUPKORPKLOZ;
}; # 下層内容開始了
$m->grupkorp($optsr, '!');
};
$m->ustop('trying to descend to litslvl %l in a pure org-mode that started at orglvl %o', l => $m->{lits}->{__lvl}, o => $orglvl) if defined $orglvl and $orglvl > $m->{lits}->{__lvl};
$orglvl ||= $m->{lits}->{__lvl}; # the level below which no more brackets are used for grouping but only org-mode headings
$m->grupopen($optsr,'('.$ank);
};
# $m->opts_setnomval($optsr, tds => $tds) if $tds;
my $sl = $m->{lits}->{__lvl} - 1;
$m->ustop('headline prefix %p has %n stars but we are at section level %l', p => $pfx, n => $lp, l => $sl) if $sl ne $lp;
($ank, $tit);
};
my ($ank, $tit) = &$get_ank_tit;
last unless $ank;
TITSUB: { # strip possible org tags at end of title
ANKTIT: { # org title line must have anchor $ank. $ank becomes title $tit if not specified. no more checks in that case
last if $tit;
$tit = $ank;
last TITSUB;
};
my ($tit0,$tags) = $tit =~ m(\A(.*\s[^:]+)\s+(\:[\w\:]+\:)\Z);
$tit = $tit0 || $tit;
$tit = $m->grupfill($tit, lihs => $lihs);
# $m->opts_setnomval($optsr, tags => $tags) if $tags;
};
OPTS_K2V: {
my %k2v = (tit => $tit);
$k2v{lab} = $ank if $lihs->getval(org_ank2lab => 1);
while (my ($k,$v) = each %k2v) {
$m->opts_setnomval($optsr, $k => $v);
};
};
return $m->dpop1($prog,1);
};
ORGPROP: { # allow special syntax of org-mode property section
my ($s) = m(\A\s*\:(PROPERTIES|END)\:);
last unless $s;
return $m->dpop1($prog,1);
};
ORGTUP: { # allow special syntax of org-mode property tuple
my ($k, $v, $lim) = m(\A\s*\:([@%]?\w+)\:(.*)(.)\Z);
last unless $k;
$m->ustop('tuple has key %k and value %v but ends in %l rather than colon', k => $k, v => $v, l => $lim) unless $lim eq ':';
ANKNOM: { # allow orgtup values to contain links like, :sde:[[file:....][AvlMR]]]: or [[AvlMR]] or [[file:...][2020-04-05]], 見file:/phm/22/04/01/sig/_lng.phm_pub_sig220401.txt::anknom
my ($nom) = $v =~ m(\A\[\[(.*)\]\]\Z);
last unless $nom;
do { $v = $1;last } if $nom =~ m(([^\133]+)\Z); # everything behind the last '\133' = asc 13x8+3 = 91 = sqbrak0, cf file:/phm/22/05/01/sig/_lng.phm_pub_sig220501.txt::anknom
};
$m->opts_setnomval($optsr,$k,$v);
return $m->dpop1($prog,1);
};
ORGPLAN: { # allow special syntax of org-mode planning info tuple
my ($k, $v) = m(\A\s*(SCHEDULED|DEADLINE|CLOSED|PRIORITY)\:\s*(.*)\s*\Z);
last unless $v;
$m->opts_setnomval($optsr, $k, $v);
return $m->dpop1($prog,1);
};
KORPSTART: {
my @korpstart = m(\A([?!])([:]?)\Z);
last unless @korpstart;
$m->grupkorp($optsr, @korpstart);
return $m->dpop1($prog,1);
};
# we are entering a body anyway, but implicitely, without returning, with need to go on parsing this line as first line of body
$m->grupkorp($optsr, '!');
};
OPENKLOZ: { # Smettiamo di parsare se stiamo aprendo o chiudendo un gruppo oppure se restiamo fuori del gruppo.
my $ok = '';
my $nom2 = '';
my $ch = substr $_, 0, 1;
OPEN: { # NEWSUBGRUP 似乎應開啟下屬物體 file:/phm/19/05/22/sig/_org.phm_pub_sig190522.txt::newsub
last if $ch ne '(';
($ok,$nom2) = $m->grupopen($optsr,$_);
$m->ustop(litnom_p => k => $nom2) if $nom2 =~ m(\_\Z) or $nom2 =~ m(\A\_);
last OPENKLOZ if ! $ok;
$m->debug_litnom($nom2);
return $m->dpop1($prog,1);
};
KLOZ: {
last if $ch ne ')';
ORGKLOZ: { #
last unless defined $orglvl;
LVLTRO: { # level exceeds orglvl
my $lvl = $m->{lits}->{__lvl};
last unless $lvl > $orglvl;
$m->grupkloz($optsr,')');
$m->pstop('grupkloz failed to reduce level %l', l => $lvl) unless $m->{lits}->{__lvl} < $lvl;
redo LVLTRO;
};
};
($ok, $nom2) = $m->grupkloz($optsr,$_);
$orglvl = undef;
last OPENKLOZ if ! $ok;
$m->debug_litnom($nom2);
return $m->dpop1($prog,1);
};
};
NONOM: { # Subblock Nonom
#if we are neither in a text group nor opening a new one, we conclude group syntax parsing unsuccessfully
last if $nom;
return $m->dpop1($prog,0);
};
FINLINI: {
# Text body lines are treated with trailing comments not removed, assuming that they could be from quote/verbatim environments and that if we write inline comments ourselves we have better syntactical means for that, e.g. C<$(koment|comment text|1)> evaluating to C<1> only.
last unless $m->{lits}->{__fin};
$m->gruplini($optsr,$lini) if $m->{lits}->{__fin} == 1;
return $m->dpop1($prog,1);
};
$m->pwarn(gnopars => s => $_, n => $nom, l => $m->{lits});
$m->dpop1($prog,0);
};
=head4 Function sfx2fun
Given
ahval = [[$(value ${1}_url)][$(or ${2}${3}${4},$(value ${1}_tit))]!]
%sfx2fun = ||url|+call+ahval+1+2+3+||call|+call+||proc|+proc+|
Set implicit functions triggered by suffixes (sfx) such as 'url'.
EBNF
args := vars, fol
rets := verb, args
vars := hashref
vars :: group variables
fol := string
fol => 'xa_url'
fol :: leaf name of the variable that might trigger an implicit function assignment
fol2 => 'xa_ahval_1_2_3_call'
fol2 :: equivalent of fol
verb :: 'xa'
args :: 'call', 'ahval', '1', '2', '3'
TODO: ensure that group variable call will finally call a general variable that was defined outside the document
=cut
sub sfx2fun {
my ($m,$prog,$lihs,$gvars,$fol,%opts) = shift->ogpuc('sfx2fun',1,@_);
$m->pstop(funnovar => v => 'fol') unless $fol;
my @fol_args = split '_', $fol;
my $fol_sfx = pop @fol_args; # e.g. 'url'
return $m->dpop($prog) unless @fol_args;
$m->pstop(funnovar => v => 'vars') unless $gvars;
my $get_sfx2fun = sub {
my $sfx2fun = $gvars->{sfx2fun};
SFX2FUN: {
last if 'HASH' eq ref $sfx2fun;
$sfx2fun = $lihs->{hacs}->{sfx2fun};
last if 'HASH' eq ref $sfx2fun;
$sfx2fun = $lihs->getstr('sfx2fun');
last unless $sfx2fun;
$m->pwarn('obtaining sfx2fun from string variable');
$sfx2fun = $m->str2arb($sfx2fun);
};
if ($sfx2fun) {
$m->pstop('nonhash value %v stored under sfx2fun in in hacs', v => $sfx2fun) unless 'HASH' eq ref $sfx2fun;
$gvars->{sfx2fun} = $sfx2fun;
};
$sfx2fun;
};
my $sfx2fun = &$get_sfx2fun;
my $fol_verb = shift @fol_args; # e.g. 'xa'
my $fun = $sfx2fun->{$fol_sfx} or return $m->dpop($prog);
my @funs = $m->x2list($fun);
$m->ustop('empty function defined for %x in sfx2fun', x => $fol_sfx) unless @funs;
push @funs, $fol_verb; # 'xa_1_2_3_url', transmit name, value must be obtained later
push @funs, @fol_args if @fol_args; # xa_1_2_3_url => [ 'call', 'ahurlval_verb', 'xa_1_2_3_url', '1', '2', '3', @_ ] || [ 'call', 'ahurlval_verb', 'sp' ]
$gvars->{$fol_verb} = [ @funs ]; # $gvars->{xa} = [ 'call', 'ahval', 'xa', 1, 2, 3 ];
$m->dpop($prog,$fol_verb, @funs);
};
=head3 Naming of Variables
=head4 $m->tmplini_setnomval(...) => ...:
Perform what was recognised by the setnomval regex to be a variable assignment statement.
Take the matched substrings of that regex as arguments, i.e.
@args => $opts, $verb, $nom, $nurdefp, $statvar, $val
$opts => { rank => 1 }
$verb => 'export'
$nom => 'tit'
$nurdefp => '?' :: write only if still undefined; override this by option redefp => 1 thereby in effect switching off the '?' effect
$kalkop => '+-*/%' :: calculation operator
$statvar => ':'
$val => 'Function tmplini_setnomval'
Return the name and value that were used in the assignment.
Return nothing if nothing was assigned.
The return value is unimportant because in either case tmplini ends after this.
=cut
sub lvals2valll {
my ($m,$prog,$lihs,$lang,$vall,$langl,$sup) = shift->lpuc('lvals2valll',@_);
my @vals = @$vall;$sup ||= $m->{lits}->{__nom};
my @langs = 'ARRAY' eq ref $langl ? @$langl : $sup ? $m->grupvars_getlst($lihs, slngs => $sup) : $m->plst(langs => 1);
my %ll2val = ();
my $i = 0;
while ($i <= $#langs) {
last unless $vals[$i];
$ll2val{$langs[$i]} = $vals[$i];
} continue { $i++ };
my $ll = 'la';
while ($i < $#vals) { # ||fr|encore une langue||it|ancora una lingua|
next if $vals[++$i]; # looking for the first empty position ||
$i++;$ll = $vals[$i];$m->ustop('bad language %l at position %i of %V', l => $ll, i => $i, V => \@vals) unless $ll =~ m(\A\w{2}\Z);
$i++;$m->ustop('looking for value for language %l at %i beyond end of %V', l => $ll, i => $i, V => \@vals) if $i > $#vals;$ll2val{$ll} = $vals[$i];
};
my $val = $ll2val{$lang};
unless ($val) { $val = $vals[0];$lang = $langs[0] };
$m->dpop($prog,$val,$lang);
};
sub val2lval { # tit = |特許請求の範囲|Patentanspruchsbereich||zh|權利主張範圍|, 根據 @slngs 或 $opts{langs}, file:/adv/perl/A2E/MLMK.pm.tmpl::val2lval file:/adv/perl/A2E/Tmplfil.pm.tmpl::/\bval2lval\b/
my ($m,$prog,$lihs,$val,$ll,%opts) = shift->lpuc('val2lval',@_); # $tit, sup => 'rev', langs => ['ja','de']
return $m->dpop($prog,$val,$ll) unless $val and $ll;
my $sup = $opts{sup} || $m->{lits}->{__sup};
my @langs = ();
LANGS: {
my $sls = $opts{langs};
@langs = @$sls if $sls;
last if @langs;
@langs = $m->grupvars_getlst($lihs, slngs => $sup);
last if @langs;
return $m->dpop($prog,$val,$ll);
};
my $langs_nbr = scalar @langs;
return $m->dpop($prog,$val,$ll) unless $langs_nbr > 1;
my $sep = substr $val, 0, 1;
return $m->dpop($prog,$val,$ll) unless $m->arbsepp($sep);
my $len = length $val;$len--;
my $sep1 = substr $val, $len;
return $m->dpop($prog,$val,$ll) unless $sep eq $sep1;
my @vals = $m->textsep2list($val,$sep);
($val,$ll) = $m->lvals2valll($lihs,$ll,\@vals,\@langs,$sup);
$m->dpop($prog,$val,$ll);
};
sub setvfol { # set functions corresponding to 'vf_url', 'vf_dok', 'vf_proc' and similar when suffixes 'url' and 'dok' are registered in %sfx2fun
# %sfx2fun = ||url|+call+ahurlval_verb+||dok|+call+ahdokval_verb+||proc|+proc+||call|+call+|
my ($m,$prog,$lihs,$gvars,$fol,$sup,%opts) = shift->ogpuc('setvfol',2,@_);
my ($vfol) = $m->sfx2fun($fol,%opts); # 'xa_url' => 'xa'
return $m->dpop($prog) unless $vfol;
my $funs = $gvars->{$vfol}; # [ 'call', 'ahurlval_verb', 'xa_url' ]
$m->pstop(funnovar => v => $vfol) unless $funs;
my $vnom = join '_', $sup, $vfol; # korp_xa
my $nom = join '_', $sup, $fol; # korp_xa_url
$m->{lits}->{__lsts}->{$vfol} = 1;
my ($vval,$lvlmax) = $m->arb2strl($funs);
my $litstag = $m->pvar(litstag => 1);
$opts{lvlmax} = $lvlmax;$opts{litstag} = $litstag;$opts{echo} ||= $m->{debug};
$lihs->putstr($vnom => $vval, %opts);
$lihs->{lsts}->{$vnom} = $funs; # redundant but cheap
$m->dpop1($prog,$vfol);
};
=head4 tmplini_setnomval
redefp :: allow variables to be overwritten when assignement statement contains '?' e.g. tmpl ?= sig; this may be turned off with option redefp which is activated by a plus rank '?+' suffix in file:/adv/perl/A2E/Dokfs.pm.tmpl::no_redefp_rank
=cut
sub tmplini_setnomval {
my ($m,$prog,$lihs,$optsr,$gvars,$setverb,$tfol,$kverklam,$kalkop,$kolon,$val) = shift->tgpuc('tmplini_setnomval',@_);my %opts = $m->ref2hash($optsr);
my $verbose = $m->pvar('verbose');
my $rank = -1;
local $_ = $setverb; # (?:|export|unexport|set), for GNU Make compatibility
($setverb) = m(\A(\w+));
$setverb ||= '';
my $follp = 0; # whether the leaf ends in our language suffix
my $lang = $m->pvar(lang => 1);
my $litstag = $opts{litstag} // $m->pvar('litstag');
$_ = $tfol; # => '@tmls', 'tit_en'
my %putopts = ();
#
my $putflng = sub { $putopts{litstag} = 'l';$putopts{litstagarg} = $lang;$putopts{flng} = $lang }; #
FOLL2FOL: { # operate on variable name $_, cut off trailing language suffix and return if not my lang
# file:/phm/19/07/22/sig/_lng.phm_pub_sig190722.txt::foll2fol
do { &$putflng;last FOLL2FOL } if $opts{flng};
my $LX = $m->grupvars_getval($lihs, 'LX') || 'LX'; # local lingua franca
my ($nom,$ifx,$ll) = m(\A([@%]?[a-z,A-Z]\w*[a-z,A-Z])(\_|\d+)(\w+)\Z);
do { $putopts{flng} = undef;last FOLL2FOL } unless $ll and (grep { $_ eq $ll } 'LL', $LX or $m->{progvars}->{langp} ? $m->{progvars}->{langp}->{$ll} : $ll =~ m(\A[a-z]{2}\Z)); # tfol_langp
#
return $m->dpop($prog) unless grep { $_ eq $ll } $lang, $LX, 'LL';
#
#
&$putflng unless $LX eq $ll; #
$tfol = $nom;
$tfol .= $ifx if $ifx =~ m(\A\d);
$follp = 1; # whether lingual leaf cf file:/phm/20/10/06/sig/_log07adv.phm_pub_sig201006.txt::95298
};
my ($nom, $sup, $fol, $typ) = $m->lits_tfol2nom($tfol); # 'top_tmls', 'top', 'tmls', '@'
$val = $lihs->chkvar($nom,$val);
$m->ustop(lituaz => k => $nom) if $nom =~ m(\_\Z) or $nom =~ m(\A\_) or $nom =~ m(\_\_);
$lihs->{vars}->{__litnom} = $nom; # to help debugging messages
return $m->Wpop0($prog, p => 'noreahac',n => $nom, v => $typ.$nom) if $m->{lihs}->{hacs}->{$nom} and $typ ne '%';
return $m->Wpop0($prog, p => 'norealst', n => $nom, v => $typ.$nom) if $m->{lihs}->{lsts}->{$nom} and $typ ne '@';
return $m->Wpop0($prog, u => 'noovwrp', n => $nom, v => $lihs->getval($nom), w => $val) if $m->{progvars}->{$nom};
# return $m->Wpop0($prog, u => 'noovwra', n => $nom, v => $lihs->getval($nom), w => $val) if $lihs->{hacs}->{_antevarp_}->{$nom};
RANK: {
do { $rank = $TMPLVARS_FAYL_RANKS{important};$opts{redefp} = 1;last } if $opts{rank} eq '+';
do { $rank = $TMPLVARS_FAYL_RANKS{unimportant};last } if $opts{rank} eq '-';
$rank = $TMPLVARS_FAYL_RANKS{normal};
};
my $nurdefp = $opts{redefp} ? 0 : $kverklam eq '?' ? 1 : 0;
my $statvar = $kolon eq ':' ? 1 : 0; # static variable, must be evaluated before storing
return $m->dpop($prog) unless $setverb eq 'export' or $rank > $TMPLVARS_FAYL_RANKS{unimportant};
return $m->dpop($prog) if $setverb eq 'unexport' and $rank < $TMPLVARS_FAYL_RANKS{important};
#
# return $m->dpop($prog) if $nurdefp and $lihs->{vars}->{$nom};
return $m->dpop($prog) if $nurdefp and $lihs->vgetval($nom);
#
_utf8_on $val;
do { $m->tmplini_special_body($val);return $m->dpop($prog) } if 'special' eq $fol;
VAR: { # distinguish static (:=) and dynamic (=) variable assignement
#
do { $val = $m->grupfill($val, lihs => $lihs);$putopts{flng} = $lang } if $statvar; #
delete $m->{tmplarbs}->{$nom};
my $arbp = $lihs->arbtypp($typ);
$m->setvfol($fol,$sup,%opts) if $sup;
$putopts{echo} = $verbose;$putopts{litstag} = $litstag;
$putopts{$_} ||= $opts{$_} for qw(putvars flng);
my $grupvarp = $m->{lits}->{__nom}; # whether we are in a group i.e. "\A(\n...\n)" section.
if ($arbp) { # structured variables with prefixes @% stored in $lihs->{lsts} etc
if ('+' eq $kalkop) {
SEQPUCQ_KALKOP: $m->seqpucq($nom,$val,%putopts);
} else {
$val = $m->strval_defarb($lihs,$typ,$nom,$val,%putopts);
};
if ($grupvarp) { my $treg = $lihs->treg($typ);
$m->{lits}->{'__'.$treg}->{$fol} = 1 };
} else {
$m->ustop('variable %n is a list, not a string', n => $nom) if $lihs->{lstp}->{$nom};
$m->ustop('variable %n is a hash, not a string', n => $nom) if $lihs->{hacp}->{$nom};
my ($lval,$ll) = $m->val2lval($lihs, $val, $lang, sup => $m->{lits}->{__sup}) if !$follp and $m->{konfig}->lvalnomp->{$fol};
PUTSTR: {
# last if $ll ne $lang;
if ($ll) { $putopts{litstag} = 'l';$putopts{flng} = $ll;$val = $lval };
last if !$val;
$lihs->putstr($nom => $val, %putopts);
};
$m->{lits}->{__vars}->{$fol} = 1 if $grupvarp;
};
# 可省略乎
# eval { $lihs->chkvartyp($nom,$val,$fol,$typ,$optsr->{litstag}) };
#
$m->ustop('failed to set variable %n with value %v to type %t: %m', n => $nom, v => $val, t => $typ, m => $@) if $@;
$gvars->{$fol} = $val if $grupvarp;
};
SETVAR_HOOKS: { # activate 'special' variables and the like
last unless $m->{setvar_hooks}->{$nom};
$m->pstop('setvar hook of %n is not a listref', n => $nom) unless 'ARRAY' eq ref $m->{setvar_hooks}->{$nom};
my @hooks = ();
foreach my $hook (@{$m->{setvar_hooks}->{$nom}}) {
$m->pstop('invalid setvar hook for variable %n', n => $nom) unless 'ARRAY' eq ref $hook;
my $hook_opts = shift @$hook;
$m->pstop('invalid setvar hook options %h', h => $hook_opts) unless 'HASH' eq ref $hook_opts;
my $kmdverb = shift @$hook;
my $kmdfun = $m->tmplfil_special_get($kmdverb, lihs => $lihs);
$m->pstop('special directive %k not registered', k => $kmdverb) unless $kmdfun;
$m->pstop('function body of special directive %k is invalid', k => $kmdfun) unless 'CODE' eq ref $kmdfun;
my @kmdargs = map { $m->grupfill($_, lihs => $lihs) } @$hook;
my $res = eval { &$kmdfun($m, @kmdargs) };
$m->ustop(setvarargs => n => $nom, k => $kmdverb, A => \@kmdargs, e => $@) if $@;
next if $res;
$m->pwarn('directive %k executed upon setvar %n but mission not completed', k => $kmdfun, n => $nom);
push @hooks, $hook;
};
@{$m->{setvar_hooks}->{$nom}} = @hooks;
};
#
# $m->pwarn('variable name %n with value %v still not set after assignment routine', n => $nom, v => $val) if defined $val and not defined $lihs->{vars}->{$nom};
$m->{debug} && $m->pwarn('variable name %n with value %v still not set after assignment routine', n => $nom, v => $val) if defined $val and not defined $lihs->{vars}->{$nom} and not $lihs->getval($nom);
#
$m->dpop($prog,$nom,$val);
};
sub opts_setnomval {
my ($m,$prog,$lihs,$optsr,$nom,$val) = shift->tpuc('opts_setnomval',@_);
($nom,$val) = $m->tmplini_setnomval($optsr, '', $nom, '', '', ':', $val);
$m->dpop($prog,$nom,$val);
};
=head3 Conditional constructions
=head4 Function tmplini_ifsetval
Return 1 and store this in iflevel_vals of iflevel if the condition that we are parsing is true, 0 otherwise.
subroutine of tmplini,
=cut
our %ifsetfun = (
ifset => sub { $_[0] ? 1 : 0 },
ifnset => sub { $_[0] ? 0 : 1 },
ifdef => sub { defined $_[0] ? 1 : 0 },
ifndef => sub { defined $_[0] ? 0 : 1 } );
sub tmplini_ifsetval {
my ($m,$prog,$lihs,$verb,$arg,$komp) = shift->lpuc('tmplini_ifsetval',@_);local @_;local $_;
$m->ustop('conditional verb %v without argument', v => $verb) unless $arg;
my $valp = 0;
my ($parg) = $arg =~ m(\A\s*[\x28](.*)[\x29]\Z);# parenthesis argument
@_ = do { if ($parg) { $m->textsep2list($parg, ',') } else { $m->textsep2list($arg) } };
GETVAL: {
IFDEF: {
last unless $ifsetfun{$verb};
$m->pstop('extra argument %k in mononomic %v expression', v => $verb, komp => $komp) if $komp;
@_ = map { $lihs->getstr($_) } @_;
my $okp = $ifsetfun{$verb};
$m->pstop('invalid verb %v', v => $verb) if 'CODE' ne ref $okp;
foreach my $arg (@_) { $valp = &$okp($arg);last if !$valp };
last GETVAL;
};
IFEQS: {
last if 'ifeqs' ne $verb;
my ($nom,@args) = @_;
my $kval = $lihs->getstr($nom);
$m->pwarn('Empty comparison variable %n', n => $nom) if !$kval;
$m->pstop('Extraneous arguments in ifeqs: %A', A => \@args) if @args;
$m->{iflevel_komp}->{$m->{iflevel}} = $kval;
last GETVAL;
};
BINOM: {
my ($op) = $verb =~ m(\Aif(eq|ne|neq|lt|gt|le|ge)\Z);
last unless $op;
my $fun = $m->{tmplfil_kompopfuns}->{$op};
$m->pstop('unknown comparison operator %o', o => $op) unless $fun;
# Perl regex Bug: \((.*)\) does not work, [] are needed.
@_ = map { $m->grupfill($_, lihs => $lihs) } @_;
$valp = &$fun(@_) ? 1 : 0;
last GETVAL;
};
$m->pstop('unknown variable check verb %v', v => $verb);
};
$m->{iflevel_vals}->{$m->{iflevel}} = $valp;
$m->dpop1($prog,$valp);
};
=head4 Function tmplini_kondsynt
Identify an if-related statement, process it and return true if this line no longer needs to be processed by any other parsing procedures.
A true result is achieved if either
- the line was indeed am if-related syntactic statement, or
- the line belongs to a part of an if-construction that is idle because the condition for its processing is not met (section IFOK)
A true result is returned whenever it is found somewhere along the way.
If the processing goes on all the way to the end, a false result is returned.
All conditional statements are always evaluated even when we are in an idle section because otherwise we would not know when an endif ends our idle section.
=cut
our %ifverbp = (eqs => 1, def => 1, ndef => 1, set => 1, nset => 1, eq => 1, neq => 1, gt => 1, lt => 1, ge => 1, le => 1 );
our %kondverbp = ('else' => 1, elif => 1, endif => 1, case => 1);foreach my $v (keys %ifverbp) { $kondverbp{'if'.$v} = 1;$kondverbp{'elif'.$v} = 1 };
our %kondsepp = (':' => 1, '/' => 1, ';' => 1, '|' => 1);
sub tmplini_kondsynt {
my ($m,$prog,$lihs,$s) = shift->lpuc('tmplini_kondsynt',@_);local $_ = $s;
VERBS: {
last if m(\=);
my $sep = substr $_, 0, 1;
# when we are in a group and want to use conditionals, we need to start line with separator ':' or '/', where '/' leads to interpretation of args as regex
# :ifeqs:lang:
# :case:de:en:
# /case/\A(?:zh|ja|ko)\Z/
# :endif:
# Outside of groups we can use either this form or the form known from the GNU Make language
last if $m->{lits}->{__lvl} and !$kondsepp{$sep};
($sep, $_, local @_) = $m->text2seplist($_);
last unless $kondverbp{$_};
IFX: { # check for ifdef, ifndef, ifeqs, ifeq
last unless m(\Aif(\w{2,4})\Z);
do { $m->uwarn(pseudokond => c => $_);last } unless $ifverbp{$1};
# CAUTION: the regex must not catch assignment statements like 'ifeng_url = http://www.ifeng.com'.
# Conditional processing must come very early in the tmplini processing chain in order to function.
$m->{iflevel}++;
my $val = $m->tmplini_ifsetval($lihs,$_,@_);
return $m->dpop1($prog,1);
};
=item elif section
Allow C (else-if) alternatives, using the same verbs as with if.
This goes beyond the Make standard.
The C statements add a level of complexity to the logic of conditional directives.
binary comparison between perl true (1) and untrue (0) is no longer sufficient in section C.
iflevel_vals of iflevel is set to -1 if a conditional statement (in ifeq or ifeqs) was already executed.
in the ifnil section we make sure that any section where iflevel_vals of iflevel equals -1 is ignored.
=cut
ELIFX: {
last unless m(\Aelif(\w+)\Z);
do { $m->uwarn(pseudokond => c => $_);last } unless $ifverbp{$1};
last if $m->{iflevel_vals}->{$m->{iflevel}} < 0;
do { $m->{iflevel_vals}->{$m->{iflevel}} = -1;last } if $m->{iflevel_vals}->{$m->{iflevel}} > 0;
$m->tmplini_ifsetval($lihs,'if'.$1,@_);
return $m->dpop1($prog,1);
};
=item else section
=cut
ELSE: {
last unless m(\Aelse\Z);
$m->{iflevel_vals}->{$m->{iflevel}} = $m->{iflevel_vals}->{$m->{iflevel}} ? 0 : 1;
return $m->dpop1($prog,1);
};
=item case section
=cut
CASE: {
last unless m(\Acase\Z);
last if $m->{iflevel_vals}->{$m->{iflevel}} < 0;
do { $m->{iflevel_vals}->{$m->{iflevel}} = -1;last } if $m->{iflevel_vals}->{$m->{iflevel}};
my @kexps = @_;if (' ' eq $sep && 0 == $#_) { ($sep,@kexps) = $m->text2seplist($_[0]) };
my $kompar = $sep eq '/' ? $m->{kompar_match} : $m->{kompar_equal};
my $kval = $m->{iflevel_komp}->{$m->{iflevel}};
$m->{iflevel_vals}->{$m->{iflevel}} = (!@_ or do { my $res = 0;local $_;foreach my $kexp (@kexps) { if (&$kompar($kval,$kexp)) { $res = 1;last } };$res }) ? 1 : 0;
return $m->dpop1($prog,1);
};
ENDIF: {
last unless m(\Aendif\b); # allow trailing comments so that if... endif can serve as ignored section
$m->ustop('ended a group where none was open, already at level %d', $m->{iflevel}) if $m->{iflevel} < 1;
delete $m->{iflevel_vals}->{$m->{iflevel}};
delete $m->{iflevel_komp}->{$m->{iflevel}};
$m->{iflevel}--;
return $m->dpop1($prog,1);
};
}; # VERBS
IFOK: { # check whether we are the idle part of a conditional statement and if so return.
foreach my $lvl (1..$m->{iflevel}) {
next if $m->{iflevel_vals}->{$lvl} > 0;
return $m->dpop1($prog,1); # we can jump over this because condition is false at one of the levels
}
};
$m->dpop1($prog,0);
};
=head3 Multiline variable definitions with define .. endef
These variables work like in Make, see section 'Defining Variables Verbatim' of the GNU Make Texinfo manual.
They are similar to the dynamic oneline variables created by single-equal-assignments, but constitute a kind of macros that span several lines, transcend the normal text variable content and usually contain canned directive sequences (e.g. assignments, groups, conditionals) rather than text values. Their purpose is not to create long text blocks (that is done by grouping at a much later stage) but to reduce redundancy in command writing. Therefore they are available early at maketext file processing time, not at the time of final text block composition and output formatting. To achieve this, we store them as compiled trees in $m->{tmplarbs} and not in $m->{lihs}->{[lt]?vars}.
=head4 Function defnsynt
Memorize a multiline definition block from C to C as known from makefile syntax. Return nil if there is nothing to memorize.
This function is built like tmplini_kondsynt and grupsynt: it returns true after finding and processing any expression relevant to the syntax in question and, failing that, returns false at the end.
This comes at the beginning of the tmplini parsing chain because it has the effect of disabling all parsing once we are in the body of the definition.
This functionality has not been thouroughly tested.
It was prepared for in v 0.4.0 and seemed to work in dok:eupat.
=over
=item TODO: Test this functionality.
=back
=cut
sub defnsynt {
my ($m,$prog,$s) = shift->ppuc('defnsynt',@_);local $_ = $s;
my ($nom) = m(\Adefine\s+(\w+)\Z);
DEFINE: {
last unless $nom;
$_ = $nom;
$m->ustop(lituaz => k => $_) if m(\_\Z) or m(\A\_);
$m->{defn}->{__nom} = $_;
$m->{defn}->{__lst} = [];
return $m->dpop1($prog,$_);
};
ENDEF: {
my $ok = m(\Aendef\b);
last unless $ok;
$nom = $m->{defn}->{__nom};
$m->ustop(nonendef => undef) unless $nom;
$m->pstop(nodefnlst => n => $nom) unless 'ARRAY' eq ref $m->{defn}->{__lst};
my $val = join "\n", @{$m->{defn}->{__lst}};
my $arb = $m->{sarb}->parse($val);
$m->{tmplarbs}->{$nom} = $arb;
%{$m->{defn}} = ();
return $m->dpop1($prog,$nom);
};
BODY: {
$nom = $m->{defn}->{__nom};
last unless $nom;
$m->pstop(nodefnlst => n => $nom) unless 'ARRAY' eq ref $m->{defn}->{__lst};
push @{$m->{defn}->{__lst}}, $_;
return $m->dpop1($prog,$nom);
};
$m->dpop1($prog,0);
};
=head3 Line Parsing
=head4 Function tmplini_pur
restricted syntax in certain files, such as conversion tables.
we want to use the same function for these tables but without the time-consuming support of various directives and expansion mechanisms.
=cut
sub tmplini_pur {
my ($m,$prog,$lihs,$optsr,$s) = shift->tpuc('tmplini_pur',@_);local $_ = $s;my %opts = $m->ref2hash($optsr);
my @res = map { qr($_) } split m(\s+), $opts{setnomval};
push @res, qr{\A(\w+)\s*\=\s*(\S.*)\s*\Z} unless @res;
my ($nom,$val) = ();
foreach my $qre (@res) {
($nom, $val) = m($qre);
last if $nom;
};
return $m->dpop($prog) unless $nom;
$lihs->putstr($nom => $val, %opts);
$m->dpop($prog,$nom,$val);
};
=head4 Function tmplini_special
Process some special directives that are hooked in by external applications.
A prime example of this is
special process bautext_tmpl.txt
i.e. a directive to process a template and make the blocks defined therein available to the $(litsproc ...) function.
=cut
sub tmplini_special {
my ($m,$prog,$s) = shift->ppuc('tmplini_special',@_);local $_ = shift;
my ($body) = m(\Aspecial\b(.*)\Z);
return $m->dpop($prog) unless $body;
$m->ustop('old non-makefile syntax no longer supported, rewrite as pseudo variable assignement i.e. %t', t => 'special = '.$body);
my @res = $m->tmplini_special_body($body);
$m->dpop($prog,@res);
};
sub tmplini_special_body {
my ($m,$prog,$lihs,$text,%opts) = shift->opuc('tmplini_special_body',[qw(text)],@_);
my ($verb, @args) = $m->text2list($text);
my $fun = $m->tmplfil_special_get($verb,lihs => $lihs);
my @res = &$fun($m, @args);
$m->dpop($prog,@res);
};
=head4 Function tmplini_include
Include another file of the same kind.
We allow but do not encourage expansion of the filename, because that will mean that only the result of expansion based on values in the current DBM file will be traversed and all other files that could potentially be needed to generate object files will be disregarded.
To avoid this scenario, say
ifeqs styl
case jpat
include jpat_lang.txt
case dpat
include dpat_lang.txt
endif
rather than
include ${styl}_lang.txt
Linke GNU Make, we also support
-include
or
sinclude
as a way of including without insisting on the presence of the to-be-included file.
=cut
sub tmplini_include {
my ($m,$prog,$lihs,$optsr,$s) = shift->tpuc('tmplini_include',@_);my %opts = $m->ref2hash($optsr);local $_= $s;
my ($pfx,@matches) = m(\A([s\-])?include\s+(\S+)\s*\Z);
return $m->dpop($prog) unless @matches;
my $ok = 0;
my $insistp = $pfx ? 0 : 1;
my $fi = shift @matches;
$fi = $m->grupfill($fi, lihs => $lihs);
$opts{insistp} = $insistp;
$ok = $m->riid_tmplvars_fayl($fi, %opts);
$m->dpop1($prog,$ok);
};
=head4 Function tmplini_include_re
include_re han.txt (\w+):\s(\w+)
like include, but additionally supply a regular expression by which the subfile is to be parsed, in simplified (pur) mode.
This regexp should match a key and a value.
return OK if 'include_re' statement was found and file was parsed.
Like in tmplini_include, we also support the sinclude_re and -include_re versions of this directive.
=cut
sub tmplini_include_re {
my ($m,$prog,$lihs,$optsr,$s) = shift->tpuc('tmplini_include_re',@_);local $_ = $s;my %opts = $m->ref2hash($optsr);
my @matches = m(\A([s\-])?include\_re\s+(\S+)\s*(.+)\Z);
return $m->dpop($prog) unless @matches;
my $ok = 0;
my $tmp = shift @matches;
my $insistp = $tmp ? 0 : 1;
my $fi = shift @matches;
$fi = $m->grupfill($fi, lihs => $lihs);
my $re = shift @matches;
$opts{insistp} = $insistp;
$opts{setnomval} = $re;
$opts{setnomval_pur} = 1;
$ok = $m->riid_tmplvars_fayl($fi, %opts);
$m->dpop1($prog,$ok);
};
=Function tmplini_var
check that we have an assignement statement like
VAR ?:= VAL
export var = val
and if so process it.
=cut
sub tmplini_var {
my ($m,$prog,$lihs,$optsr,$s) = shift->tpuc('tmplini_var',@_);local $_ = $s;
my @nomval = m($m->{qre}->{setnomval});
return $m->dpop($prog) unless @nomval;
my $ok = $m->tmplini_setnomval($optsr,@nomval) ? 1 : 0;
$m->dpop1($prog,$ok);
};
=head4 Function tmplini
Read one line of a Makefile.
arg1 is the line.
The remaining arguments are an key-value hash with the following
qre.setnomval: regex for key-value assignment expressions, defaulting to config variable of same name
setnomval_pur: treat setnomval as a pure assignement of value to key, without any further elements
rank: '+', '-' or ''
'+': important vocabulary document, even unexport'ed variables must be evaluated
'-': unimportant vocabulary document, e.g. ancestral document's vocabulary, from which only exported variables are evaluated
'': normal vocabulary document (e.g. template, prepended file) from which all variables that are not unexport'ed are evaluated
=cut
sub tmplini {
my ($m,$prog,$lihs,$optsr,$s) = shift->tpuc('tmplini',@_);my %opts = $m->ref2hash($m->hashpush('ad',$optsr,$m->{progvars}->{tmplini_opts}));
local $_ = $s;
# Comment lines are suppressed, trainling spaces removed, but before a comment '#' sign only one space is removed. This way we can define LF TAB SPC
# They could be admitted in a linegroup by a special attribute __koment_ok, TBC cf phm_pub_sig150212
return $m->dpop($prog) if m(\A\#) and !$lihs->{__koment_ok};
$s = $m->rtrim_nokoment($_);
# empty lines are suppressed but those containing blanks are not; in the future a linegroup could also admit empty lines by means of a special attribute __blankl_ok, TBD cf phm_pub_sig150212
return $m->dpop($prog) if !length($_) and !$m->{lits}->{__blankl_ok};
return $m->dpop1($prog,1) if $m->tmplini_kondsynt($lihs,$s); # process a conditional statement or { :IFOK return because excluded by a condition }
do { $m->tmplini_pur($optsr,$_) || $m->tmplini_include_re($optsr,$s) || $m->ustop('unallowable syntax in restricted mode: %t', t => $_);$m->dpop1($prog,1);return 1 } if $opts{setnomval_pur};
# NON_FIN: { # still inside text element grup; CHANGE 190712: this stuff should be available in every context
# last if $m->{lits}->{__fin};
return $m->dpop1($prog,1) if $m->defnsynt($s); # memorizing define..endef statement
# };
$opts{rank} ||= '';
$opts{rank_ignor} = $opts{rank} eq '-' ? 1 : 0; # ignore due to low rank of file
return $m->dpop1($prog,1) if $m->grupsynt($optsr,$_,$s);
return $m->dpop1($prog,1) if defined $m->tmplini_var($optsr,$s); # file:/phm/23/01/24/sig/_lng.phm_pub_sig230124.txt::dpop_undef_if_empty
return $m->dpop1($prog,1) if defined $m->tmplini_special($s);
return $m->dpop1($prog,1) if defined $m->tmplini_include($optsr,$s);
return $m->dpop1($prog,1) if defined $m->tmplini_include_re($optsr,$s);
EVAL: { # $(foreach ... $(eval $(call ...))) construction should return null string, see tmplini_syntdefn
$m->{progvars}->{tmplini_opts} = $optsr; # used by tmplini_eval
$_ = $m->grupfill($_, lihs => $lihs);
$m->ustop(evalbad => t => $_) if m(\S);
}
$m->dpop($prog);
};
=head4 Function tmplini_eval
Ensure that a macro call such as
$(foreach bin,${BINS},$(eval $(call ..)))
will work.
TODO
=head3 Function tmplvars_fayl
Synopsis:
my ($fi, %atrs) = $m->tmplvars_fayl($fi_bas, %atrs);
Find the file that contains the template variables, return full path name and some attributes if found, nil otherwise.
We add more and pass the hash back; the C attribute is changed: it supplies the first path element to search in, and when we have found a file, the directory where we found it is returned as the new C attribute.
=cut
sub tmplvars_fayl {
my ($m,$prog,$lihs,$fi_bas,%atrs) = shift->opuc('tmplvars_fayl',1,@_);
return $m->dpop1($prog,$fi_bas) if $atrs{abs};
do { $m->pwarn('having to set template include path in tmplvars_fayl');
$m->set_template_include_path } unless $m->{cache}->{tmplopts}->{INCLUDE_PATH};
TMPLOPTS_NE_SERVICE: { # new weird case file:/phm/19/05/10/sig/_lng.phm_pub_sig190510.txt::tpaf
my $path = eval { $m->{template}->service->context->config->{INCLUDE_PATH} };
last unless $path;
unless ($m->{cache}->{tmplopts}->{INCLUDE_PATH}->[1] eq $path->[1]) { $m->pwarn('updating template include path in tmplvars_fayl cf tmplopts_ne_service from %o to %n', o => $m->{cache}->{tmplopts}->{INCLUDE_PATH}->[1], n => $path->[1]);$m->{cache}->{tmplopts}->{INCLUDE_PATH} = $path };
};
my ($dir, $tmp, $fi, $prop, $rest) = ('', '', '', '', '');
local $_;
DOKPROPS: {
$_ = $fi_bas;
($tmp, $prop) = m(\A(.*)\?(.*)\Z);
last unless $tmp;
$fi_bas = $tmp;
RANK: {
$_ = $prop;
($tmp, $rest) = m(\A([\+\-])(.*)\Z);
last unless $tmp;
$atrs{rank} = $tmp;
$prop = $rest;
};
$_ = $prop;
do { my ($kii, $val) = split '=';next unless $kii;$atrs{$kii} = $val } for split ',';
};
ABS: {
return $m->dpop($prog,$fi_bas,%atrs) if -e $fi_bas;
last unless $fi_bas =~ m(\A\.*\/);
$atrs{abs} = 1;
$atrs{nekz} = 1;
return $m->dpop($prog, $fi_bas, %atrs);
};
my @path = ();
my $clean_path = sub {
my @path0 = @{$m->{cache}->{tmplopts}->{INCLUDE_PATH}};
my %pathp = ();
my $dir = '';
my $update_path = sub {
my $insert = shift;
foreach $dir (@_) {
next unless $dir;
next unless -d $dir;
next if $pathp{$dir};
&$insert($dir);
$pathp{$dir} = 1;
} };
&$update_path(sub { push @path, @_ }, @path0, $atrs{dir});
my @path1 = reverse @{$m->{konfig}->include_extra};
&$update_path(sub { unshift @path, @_ }, @path1);
my @path2 = reverse $lihs->getlst(include_extra => 0);
&$update_path(sub { unshift @path, @_ }, @path2);
};
&$clean_path;
$atrs{path} = \@path;
@{$m->{cache}->{tmplopts}->{INCLUDE_PATH}} = @path;
DIR: {
$dir = shift @path;
next unless $dir;
$tmp = catfile $dir, $fi_bas;
FI_R: {
last unless -e $tmp;
$fi = $tmp;
$atrs{dir} = $dir;
last DIR;
};
redo DIR;
};
NOFB: {
last if $fi;
last unless $atrs{insistp};
$m->ustop(nofbinpath => { b => $fi_bas, P => $m->koniug_et(@{$atrs{path}}) });
};
$fi = $m->absfayl($fi);
$m->dpop($prog,$fi,%atrs);
};
=head3 Funtion lng_fayl_subfaylz;
Synopsis
my @subfaylz = $m->lng_fayl_subfaylz($fi, \@faylz, %fi_atrs);
Return a list of text chunk files that a particular file adds to the Makefile target list, including, if valid, the file itself and any text chunk files invoked inside it by means of C or C statements. Traverse the file and included subfiles recursively to obtain the complete list. The included files appear before the including files. Apart from that the order is the order of appearance of the include statements in the files.
Argument \@faylz lists already visited files that are no longer eligible for inclusion (and thus can not be on the list returned by this function).
Argument %fi_atrs is an attribute table as used by tmplvars_fayl, of which the $fi_atrs{dir} attribute is used to transport info about the current directory so that this can be prepended to the path and thus support relative directories in inclusion statements of text chunk files, allowing foreign directories to become temporary points of reference.
See also &A2E::MLDK::lng_faylz_src, the higher level function for which this one does most of the work.
=cut
sub lng_fayl_subfaylz {
my ($m,$prog,$lihs,$fayl,%atrs) = shift->opuc('lng_fayl_subfaylz',1,@_);
$m->pstop(funnovar => v => 'fayl') unless $fayl;
$fayl = $m->absfayl($fayl);
my $oldfaylp = $atrs{oldfaylp} || {};
return $m->Wpop0($prog, p => fprereq => f => $fayl) if $oldfaylp->{$fayl};
my @faylz = ($fayl);
$oldfaylp->{$fayl} = 1;
my $lini = 0;
$m->open_fayl($fayl, $fayl, 'r');
RIID: {
$atrs{dir} = dirname $fayl;
$atrs{dir} = $m->dir2dir if !$atrs{dir} or $atrs{dir} eq '.';
while ($m->getlini($fayl)) {
$lini++;
next unless m(\A\s*\:?include\b);
chomp;
my $fib = '';
FIB: {
($fib) = m(\Ainclude\s+(\S+)\s*\Z);last if $fib;
($fib) = m(\Ainclude\_re\s+(\S+)\s*\Z);last if $fib;
($fib) = m(\Ainclude\s*\=\s*(\S+)\s*\Z);last if $fib;
($fib) = m(\A\s*\:include\:(\S+)\:\s*\Z);last if $fib;
};
do { $m->uwarn(invexpfl => f => $fayl, l => $lini, e => $_);next } unless $fib;
$fib = $m->grupfill($fib, lihs => $lihs); # expand any variables that may be contained in the file name
my ($fi, %fi_atrs) = $m->tmplvars_fayl($fib, %atrs);
do { $m->uwarn(inkludfdko => f => $fib, D => $m->koniug_et(@{$fi_atrs{path}}));next } unless $fi;
my @subfaylz = eval { $m->lng_fayl_subfaylz($fi, %fi_atrs) };
$m->uwarn(inkludko => i => $fi, f => $fayl, l => $lini, m => $@) if $@;
push @faylz, @subfaylz;
};
$m->kloz_fayl($fayl);
};
$m->dpop($prog,@faylz);
};
=head3 Function riid_tmplvars_fayl
Example:
$m->riid_tmplvars_fayl('lang.txt', tmplvars => $m->{lang_tmplvars}, insistp => 1);
Read template variables from Makefiles. $arg1 is a file name, %arg2 is a set of attributes to that filename which may be specified via the commandline (e.g. throught the include_re statement) and augmented by parsing arg1 later.
Among these attributes, C is a local directory, e.g. that of the parent file from which the reading was initiated, that is temporarily prepended to the INCLUDE_PATH to allow us to find files by their relative pathname.
The following Makefile constructions are supported:
KEY1 := VAL1
KEY1 = VAL1
KEY2 ?= VAL2
KEY2 ?:= VAL2
KEY3 := ${VAL1}${VAL2}
KEY4 := $(shell get_val ${KEY3})
include a2e/defs.mk
etc, see tmplini. If $arg2{setnomval_pur} is set, only one construction is supported and it is treated as what in Makefile notation would be
KEY1 := VAL1
=cut
our %litstag2pvar = (l => 'lang', t => 'tml');
our %lt2lt = (f => 't', tml => 't', lang => 'l'); # translate from convention of file:/adv/perl/A2E/MLHT.pm.tmpl::fi_opts_get_template_arbvars
sub dirtagarg2llitsdir {
my ($m, $dir, $tag, $arg) = @_;
catdir $dir, join '.', $tag, $arg;
}
sub set_litsdir { # set directory to read lits from
my ($m,$prog,$lihs,$litstag0,$litstagarg) = shift->lpuc('set_litsdir',@_);$litstag0 ||= '';
my $litstag = $lt2lt{$litstag0} || $litstag0 || 'l'; # 'l'
my $pvar = $litstag2pvar{$litstag} || ''; # 'lang'
$m->pstop('litsdir tag must be t or l, not %t', t => $litstag) unless $pvar;
if ($litstagarg) { # 'de'
$m->setpvar($pvar,$litstagarg, lihs => $lihs);
# $lihs->litstag_undef_vars($litstag);
} else {
$litstagarg = ('l' eq $litstag) ? $m->pvar(lang => 1) : $m->pvar(tml => 1);
};
my $litsdir0 = $lihs->{vars}->{__litsdir__} or $m->pstop('base litsdir of lihs undefined');
$m->pstop('base litsdir does not exist') unless -d $litsdir0;
$lihs->{__nolitsdir__} = 0;
$lihs->putstr(__nolitsdir__ => 0, typ => 'd');
my $llitsdir = $m->dirtagarg2llitsdir($litsdir0, $litstag, $litstagarg);
unless (-d $llitsdir) { mkdir $llitsdir or $m->pstop('failed to make directory %D', D => $llitsdir) };
my $llitsnom = '__' . $litstag . 'litsdir__';
my $llitsdir0 = $lihs->{vars}->{$llitsnom};
if ($litstagarg and $llitsdir0 ne $llitsdir) {
$lihs->{vars}->{$llitsnom} = $llitsdir;
$lihs->litstag_undef_vars($litstag);
};
$m->setpvar('litstag',$litstag0,lihs => $lihs);
my $litsdir = !$litstag0 ? $litsdir0 : $llitsdir;
$m->setpvar('litsdir',$litsdir,lihs => $lihs);
$m->dpop1($prog,$litsdir);
};
sub litstag_opts_setvars {
my ($m,$prog,$lihs,%opts) = shift->opuc('litstag_opts_setvars',0,@_);
my $litstag = $opts{litstag};
my $litsdir = $lihs->{vars}->{__nolitsdir__} ? '' : $m->set_litsdir($lihs,$litstag,$opts{litstagarg});
my $ripetp = $opts{ripetp} || 0;
# my $flng = $opts{flng} || 0; # if this is true, write even structure info to llitsdir .lits/l.zh or .lits/t.html, assuming that .zh.txt has its own grup structures
$lihs->{vars}->{__ripetp__} = $ripetp;
$m->dpop1($prog,$litsdir);
};
sub fib2flng {
my ($m,$fib) = @_;
my ($flng) = $fib =~ m(\b(?:\_lng.\w+|lang)\.(\w{2})\.txt\Z);
$flng;
};
sub riid_tmplvars_fayl {
my ($m,$prog,$lihs,$fib,%opts) = shift->opuc('riid_tmplvars_fayl',1,@_);
$m->pstop('file to look for is not a string but a %r', r => ref($fib)) if ref $fib;
$fib = $m->grupfill($fib, lihs => $lihs);
$m->{__flvl} = 0; # riid_fib: keep track of __flvl i e text level within the file
# if ($m->{legit}->{$fib}) { $m->uwarn('refusing to read file %f a second time', f => $fib);return } else { $m->{legit}->{$fib} = 1 };
my $flng = $m->fib2flng($fib);
$opts{flng} ||= $flng if $flng;
$m->pstop('grupfill-ed file to look for %f is not a string', f => $fib) if ref $fib;
(my $fi, %opts) = $m->tmplvars_fayl($fib, %opts);
$m->litstag_opts_setvars(%opts);
$m->decho('reading without a litsdir to write to') if $lihs->{vars}->{__nolitsdir__} or !$lihs->{vars}->{__litsdir__};
unless ($fi) {
$m->ustop_or_warn(!$opts{insistp}, 'found no file named %f in include path %P', f => $fib, P => $m->{cache}->{tmplopts}->{INCLUDE_PATH});
return $m->dpop1($prog,1);
};
RE_FI: {
last unless $m->fh($fi);
$m->uwarn('attempted to read already open file %f once more', f => $fi);
return $m->dpop($prog);
};
my $verbose = $m->pvar('verbose');
printf STDERR "\n".'[ reading %s', $fi.($opts{rank}||' ') if $verbose;
$m->open_fayl($fi, $fi, 'r');
my $get_linivar = sub {
$lihs->{vars}->{__fayl} = $fi; #special variable __fayl: current file, set each time
$opts{dir} = dirname $fi;
local $_ = $fi;
s(\W)(_)g;
return '__lini'.$_.'__';
};
my $linivar = &$get_linivar;
$lihs->{vars}->{$linivar} = 0;
local $_;
while ($m->getlini($fi)) {
$lihs->{vars}->{$linivar}++;
chomp;
$m->decho(exofls => l => $lihs->{vars}->{$linivar}, f => $fi, s => $_ );
eval { $m->tmplini(\%opts,$_) };
next if ! $@;
$m->ustop(errflm => f => $fi, l => $lihs->{vars}->{$linivar}, m => $@);
};
undef $lihs->{vars}->{$linivar};
my $msg = 'OK ]'."\n";
print STDERR $msg if $verbose;
$m->kloz_fayl($fi);
delete $lihs->{vars}->{__fayl};
$m->ustop(fgeof => f => $fi, g => $m->{lits}->{__nom}) if $m->{__flvl}; # djis 201225 $m->{lits}->{__nom} and not $opts{sup};
$m->{lits} = { __lvl => 0 };
$m->dpop1($prog,1);
};
sub riid_tmplvars_fayl1 {
my ($m,$prog,$lihs,$fayl,%opts) = shift->opuc('riid_tmplvars_fayl1',1,@_);
$m->riid_tmplvars_fayl($fayl,%opts);
foreach my $litnom (@{$m->{debug_litnoms}}) {
$m->pwarn('after reading file %f variable %n has value %v', f => $fayl, n => $litnom, v => $lihs->{vars}->{$litnom});
};
$m->dpop1($prog,1);
}
=head3 Function riid_tmplvars_faylz
Read all series of maketext files based on some given options
args := initvars, optsref, fayl+
rets := ok
Invoked via A2E::MLDK or A2E::MLMK:
$m->riid_tmplvars_faylz({ dok => $dok, langs => $langs_str, lang0 => $lang0 }, { msglini => 1 }, @fayls);
=cut
sub riid_tmplvars_faylz {
my ($m,$prog,$initvars,$optsr,@faylz) = shift->ppuc('riid_tmplvars_faylz',@_);my %opts = $m->ref2hash($optsr);
$m->riid_tmplvars_init($initvars, %opts);
foreach my $fayl (@faylz) { $m->riid_tmplvars_fayl1($fayl, %opts) };
$m->riid_tmplvars_post;
$m->dpop1($prog,1);
};
=head2 Top level functions
=head3 Function tmplfil1
Process one template.
=cut
sub tmplfil1 {
my ($m,$prog,$fi,%opts) = shift->ppuc('tmplfil1',@_);
my $tmplvars = $opts{tmplvars} || $m->{lihs}->{vars};
my $template = $opts{template} || $m->{template};
$template->process($fi, $tmplvars);
$m->pstop($m->{template}->error()) if $@;
$m->sav2out;
$m->dpop1($prog,1);
};
=head3 Function tmplfil
Process all templates supplied through the infaylz option and the [commandline] arguments.
=cut
sub tmplfil {
my ($m,$prog,@faylz) = shift->ppuc('tmplfil',@_);
$m->{konfig}->infaylz($_) for @faylz;
$m->set_template;
$m->tmplfil1($_) for @{$m->{konfig}->infaylz};
$m->dpop1($prog,1);
};
1;
=head2 Changelog
=over
=item file:/phm/23/01/31/sig/_lng.phm_pub_sig230131.txt::kalkop
=back
# Local Variables:
# coding: utf-8
# mode: perl
# srcfile: "/adv/perl/A2E/Tmplfil.pm.tmpl"
# End: