mirror
/
Enterprise-Onion-Toolkit
kopia lustrzana https://github.com/alecmuffett/eotk
1
0
Forkuj 0
Kod Zgłoszenia Projekty Wydania Wiki Aktywność
Enterprise-Onion-Toolkit/lib.d/expand-template.pl

497 wiersze
12 KiB
Raku
Executable File
Czysty Bezpośredni odnośnik Wina Historia

#!/bin/sh
exec perl -wx $0 "$@";
#!perl
# eotk (c) 2017-2020 Alec Muffett
use Data::Dumper;
my $debug = 1;
my %used = (); # debug tracking for used variable names
my @scopes = (); # lookaside contexts for local variables
my @dataset = (); # the input rules
my @template = (); # the template, obvs
# ------------------------------------------------------------------
sub Warn {
my $warning = join('', @_);
warn "$warning\n" if ($debug);
}
sub Lookup {
my $var = shift;
return '%' if ($var eq '');
$used{$var} = 1;
foreach $symref (@scopes) {
if (defined(${$symref}{$var})) {
return ${$symref}{$var};
}
}
if (defined($ENV{$var})) {
return $ENV{$var};
}
&Warn("start dumping scopes");
foreach $symref (@scopes) {
&Warn(Dumper($symref));
}
&Warn("finish dumping scopes");
die "lookup: variable named '$var' not set\n";
}
sub Evaluate {
&Warn("Evaluate @_");
my @args = @_;
if ($#args < 0) {
&Warn("EvaluateUndef");
return 0;
}
if ($#args == 0) { # single word? return it, let Perl evaluate
&Warn("Evaluate0 $args[0]");
return $args[0];
}
if ($#args == 1 and (
($args[0] eq "not") or
($args[0] eq "!"))) {
&Warn("Evaluate1-not $args[1]");
return not $args[1];
}
if ($#args >= 1 and
$args[0] =~ m!exists?!o) {
shift(@args);
&Warn("Evaluate1-exist @args");
foreach my $fname (@args) {
return 0 unless (-f $fname); # fail if any do not exist
}
return 1;
}
if ($#args == 2) {
my ($a, $op, $b, @junk) = @args;
&Warn("Evaluate2 $a");
&Warn("Evaluate2 $op");
&Warn("Evaluate2 $b");
# numeric
return ($a == $b) if ($op eq "==");
return ($a != $b) if ($op eq "!=");
return ($a >= $b) if ($op eq ">=");
return ($a <= $b) if ($op eq "<=");
return ($a > $b) if ($op eq ">");
return ($a < $b) if ($op eq "<");
# string
return ($a eq $b) if ($op eq "eq");
return ($a ne $b) if ($op eq "ne");
return ($a ge $b) if ($op eq "ge");
return ($a le $b) if ($op eq "le");
return ($a gt $b) if ($op eq "gt");
return ($a lt $b) if ($op eq "lt");
# logic
return ($a and $b) if ($op eq "and");
return ($a or $b) if ($op eq "or");
return ($a xor $b) if ($op eq "xor");
# substr
return (index($a, $b) >= 0) if ($op eq "contains");
return !(index($a, $b) >= 0) if ($op eq "!contains");
}
warn "evaluate: expression not parsed, returning for verbatim eval as string: @args\n";
return "@args";
}
sub Echo {
&Warn("Echo1 @_");
my $line = shift;
if ($line =~ /%/) {
$line =~ s/%([\w+]*)%/&Lookup($1)/ge;
}
&Warn("Echo2 $line");
print $line;
}
sub FindMatching {
my $btoken = shift;
my $etoken = shift;
my $i = shift;
my $nestlevel = 0;
&Warn("looking for $etoken starting from $i $template[$i]");
for (undef; $i <= $#template; $i++) {
if ($template[$i] =~ /^\s*$btoken\b/) {
$nestlevel++;
next;
}
if ($template[$i] =~ /^\s*$etoken\b/) {
if ($nestlevel > 0) {
&Warn("found nested($nestlevel) $etoken at $i $template[$i]");
$nestlevel--;
next;
}
&Warn("found $etoken at $i $template[$i]");
return $i;
}
}
die "runaway search for $etoken\n";
}
sub PrintExpansion {
my ($begin, $end) = @_; # inclusive
&Warn("expand begin: $begin $template[$begin]");
&Warn("expand end: $end $template[$end]");
my @vars = split(" ", $dataset[0]); # 1st line is vars
&Warn("vars: @vars");
# push down a scope
my %scope = ();
unshift(@scopes, \%scope);
&Warn("scope $#scopes pushed");
# load the variables into the local scope
for (my $i = 1; $i <= $#dataset; $i++) { # 2nd line onwards
# split the input
my @vals = split(" ", $dataset[$i]);
&Warn("vals: @vals");
# sanity check
die "array mismatch:\n@vars\n@vals\n" if ($#vars != $#vals);
# populate the scope
my $j = 0;
foreach my $val (@vals) {
$var = $vars[$j++];
$scope{$var} = $val;
&Warn("setting $var = $val in scope $#scopes");
}
# print the block
&PrintBlock($begin, $end);
}
# nuke the scope
shift(@scopes);
&Warn("scope popped, now at $#scopes");
}
sub PrintRange {
my ($line, $begin, $end) = @_;
&Warn("range begin: $begin $template[$begin]");
&Warn("range end: $end $template[$end]");
# limits
$line =~ s/%([\w+]*)%/&Lookup($1)/ge;
my ($crap, $var, $start, $finish, @rest) = split(" ", $line);
&Warn("range: $var, $start, $finish");
# push down a scope
my %scope = ();
unshift(@scopes, \%scope);
&Warn("scope $#scopes pushed");
# loop
for (my $val = $start; $val <= $finish; $val++) {
# populate the scope
$scope{$var} = $val;
# print the block
&PrintBlock($begin, $end);
}
# nuke the scope
shift(@scopes);
&Warn("scope popped, now at $#scopes");
}
sub PrintCsv {
my ($line, $begin, $end) = @_;
&Warn("csv begin: $begin $template[$begin]");
&Warn("csv end: $end $template[$end]");
# limits
$line =~ s/%([\w+]*)%/&Lookup($1)/ge;
my ($crap, @csvs) = split(" ", $line);
&Warn("csv: @csvs");
foreach my $csv (@csvs) {
# push down a scope
my %scope = ();
unshift(@scopes, \%scope);
&Warn("scope $#scopes pushed");
# %0% = whole thing
$scope{"0"} = $csv;
# %1%... = elements
my $i = 1;
foreach my $element (split(/,/, $csv)) {
$scope{"$i"} = $element;
$i++;
}
# print the block
&PrintBlock($begin, $end);
# nuke the scope
shift(@scopes);
&Warn("scope popped, now at $#scopes");
}
}
sub PrintIf { # having %%ELSE makes this a little more complex
my $start = shift;
my $cond = $template[$start];
my $nestlevel = 0;
&Warn("found %%IF at $start: $cond");
my $fi_ptr = undef;
my $else_ptr = undef;
for (my $i = $start + 1; $i <= $#template; $i++) {
if ($template[$i] =~ /^\s*%%IF\b/) { # nested
&Warn("found nested($nestlevel) %%IF at $i: $template[$i]");
$nestlevel++;
next;
}
if ($template[$i] =~ /^\s*%%ENDIF\b/) {
if ($nestlevel > 0) {
&Warn("found nested($nestlevel) %%ENDIF at $i: $template[$i]");
$nestlevel--;
next;
}
&Warn("found %%ENDIF at $i: $template[$i]");
$fi_ptr = $i;
last;
}
if ($template[$i] =~ /^\s*%%ELSE\b/) {
next if ($nestlevel > 0); # stay blind to nested code
&Warn("found %%ELSE at $i: $template[$i]");
$else_ptr = $i;
}
}
die "runaway search for %%ENDIF\n" if (!defined($fi_ptr));
# expand all %VARIABLES%
$cond =~ s/%([\w+]*)%/&Lookup($1)/ge;
&Warn("if-expand: $cond");
# evaluate the resulting string
my ($ifstmt, @args) = split(" ", $cond);
my $result = &Evaluate(@args);
&Warn("result: $result");
# act on the result
if ($result) { # true
&Warn("print true block");
my $begin2 = $start + 1;
my $end2 = defined($else_ptr) ? ($else_ptr - 1) : ($fi_ptr - 1);
&PrintBlock($begin2, $end2);
}
elsif (defined($else_ptr)) { # false, maybe print else-block?
&Warn("print else block");
my $begin2 = $else_ptr + 1;
my $end2 = $fi_ptr - 1;
&PrintBlock($begin2, $end2);
}
return $fi_ptr;
}
sub FindMatchingEnd {
return &FindMatching('%%BEGIN', '%%END', @_);
}
sub FindMatchingEndRange {
return &FindMatching('%%RANGE', '%%ENDRANGE', @_);
}
sub FindMatchingEndCsv {
return &FindMatching('%%CSV', '%%ENDCSV', @_);
}
sub Splice { # THIS IS NOT THE SAME AS "%%INCLUDE", CONTENTS NOT PROCESSED
&Warn("Splice: @_");
my $flist = shift;
$flist =~ s/%([\w+]*)%/&Lookup($1)/ge;
my ($junk, @filenames) = split(" ", $flist);
foreach my $file (@filenames) {
&Warn("Splicing: $file");
open(FILE, $file) || die "Splice: $file: $!\n";
my $line;
while ($line = <FILE>) {
print $line; # no point in slurping this one
}
close(FILE);
}
}
sub Slurp {
&Warn("Slurp: @_");
my $flist = shift;
my ($junk, @filenames) = split(" ", $flist);
my @lines = ();
foreach my $file (@filenames) {
&Warn("Slurping: $file");
open(FILE, $file) || die "Slurp: $file: $!\n";
push(@lines, <FILE>);
close(FILE);
}
return @lines;
}
sub PrintBlock {
my ($begin, $end) = @_; # inclusive
&Warn("PrintBlock: begin at $begin, end at $end");
if ($begin > $end) {
warn "begin: $template[$begin]";
warn "end: $template[$end]";
if (($begin - $end) == 1) {
warn "PrintBlock: info: empty block\n";
} else {
die "PrintBlock: end($end) before begin($begin)\n";
}
return;
}
for (my $i = $begin; $i <= $end; $i++) {
my $line = $template[$i];
if ($line =~ /^\s*%%IF\b/) {
$i = &PrintIf($i); # point at %%ENDIF
die "bounds error $begin/$i/$end\n" if ($i < $begin or $i > $end);
next; # bump pointer and continue
}
if ($line =~ /^\s*%%RANGE\b/) {
my $begin2 = $i + 1;
my $end2 = FindMatchingEndRange($begin2) - 1;
if ($end2 >= $begin2) {
&PrintRange($line, $begin2, $end2);
}
else {
&Warn("empty or negative range block: $begin2 $end2");
}
$i = $end2 + 1; # point at %%ENDRANGE
next; # bump pointer and continue
}
if ($line =~ /^\s*%%CSV\b/) {
my $begin2 = $i + 1;
my $end2 = FindMatchingEndCsv($begin2) - 1;
if ($end2 >= $begin2) {
&PrintCsv($line, $begin2, $end2);
}
else {
&Warn("empty or negative csv block: $begin2 $end2");
}
$i = $end2 + 1; # point at %%ENDCSV
next; # bump pointer and continue
}
if ($line =~ /^\s*%%BEGIN\b/) {
my $begin2 = $i + 1;
my $end2 = FindMatchingEnd($begin2) - 1;
if ($end2 >= $begin2) {
&PrintExpansion($begin2, $end2);
}
else {
&Warn("empty or negative iteration block: $begin2 $end2");
}
$i = $end2 + 1; # point at %%END
next; # bump pointer and continue
}
if ($line =~ /^\s*%%SPLICE\b/) {
&Splice($template[$i]);
next;
}
&Echo($template[$i]);
}
}
# ------------------------------------------------------------------
# get the template
if ($#ARGV < 0) {
die "usage: expand-template.pl [--debug] templatefile < dataset\n"
}
if ($ARGV[0] eq '--debug') {
$debug = 1;
shift(@ARGV);
}
$template = $ARGV[0];
open(TEMPLATE, $template) or die "open: $template: $!\n";
@template = <TEMPLATE>; # DO NOT CHOMP
close(TEMPLATE);
# expand the template
my $include_flag;
my $include_count = 0;
do {
if ($include_count > 50) {
die "$0: too many includes. infinite loop?\n";
}
$include_flag = 0;
my @new_template = ();
foreach my $line (@template) {
if ($line !~ /^\s*%%INCLUDE\b/) {
push(@new_template, $line);
next;
}
&Warn("processing include: $line");
$include_flag++;
$include_count++;
my @include_body = &Slurp($line);
push(@new_template, @include_body);
}
@template = @new_template; # swap
} while ($include_flag > 0);
# ------------------------------------------------------------------
# get the dataset to work on
chomp(@dataset = <STDIN>);
# ------------------------------------------------------------------
# print the results
&PrintBlock(0, $#template);
# ------------------------------------------------------------------
&Warn("symbol dump:");
foreach $v (sort keys %used) {
&Warn("$v");
}
# ------------------------------------------------------------------
exit 0;
Reference in New Issue View Git Blame Kopiuj bezpośredni odnośnik