302 lines
8.1 KiB
Perl
Executable File
302 lines
8.1 KiB
Perl
Executable File
#!/usr/bin/env perl
|
|
|
|
# $Header: /cvs/G/EPICS/App/scripts/dbLoadTemplate,v 1.11 2016/02/19 12:31:15 zimoch Exp $
|
|
|
|
use strict;
|
|
use Getopt::Long;
|
|
use Data::Dumper;
|
|
|
|
my $show_lines;
|
|
my @include_dirs;
|
|
GetOptions ("L" => \$show_lines,
|
|
"I=s" => \@include_dirs)
|
|
or die("Error in command line arguments\n");
|
|
|
|
my $QUOTECHAR = '"';
|
|
my $NOWORDCHAR = ",(){}=";
|
|
|
|
my $NOWORD=qr/[${NOWORDCHAR}${QUOTECHAR}]/; # single non-word character
|
|
my $WORD=qr/[^\s${NOWORDCHAR}${QUOTECHAR}]+/; # unquoted word
|
|
my $STRING=qr/(?:$QUOTECHAR((?:\\.|\\\n|.)*?)$QUOTECHAR)/; # quoted string
|
|
my $SUBST=qr/(\$\(.*?\)|[^\s${NOWORDCHAR}${QUOTECHAR}])+/; # unquoted word with $(macro) allowed
|
|
|
|
# nextToken returns the next input word, string, or char
|
|
# It skips comments and whitespace
|
|
# it dies at end of file or on unterminated string
|
|
our $input = "";
|
|
|
|
sub nextToken {
|
|
my $flags = shift;
|
|
while ($input =~ /^\s*(#|$)/) {
|
|
$input = <ARGV>;
|
|
if (!defined $input) {
|
|
return if index ($flags, "e") >= $[;
|
|
die "$ARGV:$.: unexpected end of file\n";
|
|
}
|
|
}
|
|
$input =~ s/^\s*($STRING|$SUBST|$WORD|$NOWORD)\s*(#.*\n?)?//;
|
|
$1 ne $QUOTECHAR or die "$ARGV:$.: unterminated string\n";
|
|
#print STDERR "nextToken from $ARGV:$. is $1\n";
|
|
$1;
|
|
}
|
|
|
|
sub peekToken {
|
|
my $token;
|
|
$token = nextToken;
|
|
$input = "$token $input";
|
|
$token;
|
|
}
|
|
|
|
our %subst;
|
|
our %global;
|
|
|
|
sub expand;
|
|
|
|
sub replace {
|
|
my $macro = shift;
|
|
my $default = shift;
|
|
if (defined $subst{$macro}) { return $subst{$macro}; }
|
|
if (defined $default) {
|
|
print "$ARGV:$.:$macro default $default\n";
|
|
return $default;
|
|
}
|
|
die "$ARGV:$.: macro \$($macro) undefined\n";
|
|
}
|
|
|
|
sub expand {
|
|
m/\$\(([^)]*)$/ and die "$ARGV:$.: unterminated macro \$($1\n";
|
|
%subst and s/\$\(([^=)]*)?(=([^)]*))?\)/replace $1,$3/ge; # replace macros
|
|
$_;
|
|
}
|
|
|
|
sub expect {
|
|
my ($desc, $success, $token);
|
|
foreach my $want (@_) {
|
|
$_ = nextToken;
|
|
if (length $want == 1) { # single character
|
|
$desc = "'$want'";
|
|
$success = $_ eq $want;
|
|
} else {
|
|
(my $expr, $desc) = split / /, $want, 2;
|
|
$desc = "'$expr'" if $desc eq "";
|
|
$success = /^$expr$/;
|
|
}
|
|
$success or die "$ARGV:$.: parse error: found '$_' instead of $desc\n";
|
|
}
|
|
s/^$QUOTECHAR(.*)$QUOTECHAR$/$1/; # remove quotes around strings
|
|
expand;
|
|
}
|
|
|
|
sub findFile {
|
|
my $filename = shift;
|
|
if (-e $filename) { return $filename; }
|
|
foreach my $dir (@include_dirs) {
|
|
my $path = "$dir/$filename";
|
|
if (-e $path) { return $path; }
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub handleRecord;
|
|
sub handleAlias;
|
|
|
|
sub parseRecord {
|
|
eval { expect "g?record|alias 'record' or 'grecord' or 'alias'" };
|
|
# print STDERR "parseRecord $ARGV:$.\n";
|
|
if ($@) {
|
|
$@ =~ /end of file/ or die $@;
|
|
return 0;
|
|
}
|
|
|
|
if ($_ eq "alias") {
|
|
my $name = expect "(", "$STRING quoted record name";
|
|
my $alias = expect ",", "$STRING quoted alias name";
|
|
expect ")";
|
|
handleAlias $name, $alias, $.;
|
|
return 1;
|
|
}
|
|
|
|
my $rtype = expect "(", "$WORD record type";
|
|
my $name = expect ",", "$STRING quoted record name";
|
|
my $line = $.;
|
|
expect ")";
|
|
eval {expect "{";};
|
|
if ($@) {
|
|
$@ =~ /end of file/ or die $@;
|
|
handleRecord $rtype,$name,$line;
|
|
return 0;
|
|
}
|
|
my @fields;
|
|
my @aliases;
|
|
while (1) {
|
|
expect "field|alias|info|} 'field or alias or info'";
|
|
if ($_ eq "alias") {
|
|
push @aliases, expect "(", "$STRING quoted alias name";
|
|
expect ")";
|
|
next;
|
|
}
|
|
if ($_ eq "info") {
|
|
expect "(", "$WORD info name", ",", "$STRING|$SUBST quoted info value", ")";
|
|
next;
|
|
}
|
|
last if $_ eq "}";
|
|
push @fields, expect "(", "$WORD field name";
|
|
push @fields, expect ",", "$STRING|$SUBST quoted field value";
|
|
push @fields, $.;
|
|
expect ")";
|
|
}
|
|
handleRecord $rtype,$name,$line,@fields;
|
|
while (@aliases) {
|
|
handleAlias $name, shift @aliases;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
sub parseTemplate {
|
|
# print STDERR "parseTemplate @_\n";
|
|
if (@_) {
|
|
local *ARGV;
|
|
local $input;
|
|
@ARGV = @_;
|
|
if ($show_lines) { print "# file @_\n";}
|
|
while (parseRecord) {};
|
|
} else {
|
|
while (parseRecord) {};
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
sub parseSubst {
|
|
# print STDERR "parseSubst $ARGV:$.\n";
|
|
eval { expect "file|global" };
|
|
if ($@) {
|
|
$@ =~ /end of file/ or die $@;
|
|
return 0;
|
|
}
|
|
if ($_ eq "global") {
|
|
expect "{";
|
|
while (1) {
|
|
my $macro;
|
|
$macro = expect "$WORD|,|} macro name";
|
|
# one comma allowed
|
|
if ($_ eq ",") {$macro = expect "$WORD|} macro name";}
|
|
last if $_ eq '}';
|
|
expect "=", "$STRING|$SUBST value for $macro";
|
|
$global{$macro} = $_;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
my $filename = expect "$STRING|$WORD file name";
|
|
$filename = findFile $filename or die "$ARGV:$.: template file $filename not found\n";
|
|
eval { expect "{","pattern|{ 'pattern' or '{'" };
|
|
if ($_ eq "{") {
|
|
# old style substitution
|
|
do {
|
|
local %subst = %global;
|
|
while (1) {
|
|
my $macro;
|
|
$macro = expect "$WORD|,|} macro name";
|
|
# one comma allowed
|
|
if ($_ eq ",") {$macro = expect "$WORD|} macro name";}
|
|
last if $_ eq '}';
|
|
expect "=", "$STRING|$SUBST value for $macro";
|
|
$subst{$macro} = $_;
|
|
}
|
|
my $n;
|
|
$n = scalar (keys %subst);
|
|
if ($n > 100) {
|
|
print STDERR "Warning: more than 100 marcos ($n in your case): Don't forget to adjust var dbTemplateMaxVars\n";
|
|
}
|
|
eval {parseTemplate $filename} or die "$@$ARGV:$.: called from here\n";
|
|
expect "{|} '{' or '}'";
|
|
} while $_ eq "{";
|
|
} else {
|
|
# pattern substitution
|
|
expect "{";
|
|
my @macros;
|
|
while (1) {
|
|
expect "$WORD|,|} macro name";
|
|
# one comma allowed
|
|
if ($_ eq ",") {expect "$WORD|} macro name";}
|
|
last if $_ eq '}';
|
|
push @macros, $_;
|
|
};
|
|
my $n;
|
|
$n = scalar (@macros);
|
|
if ($n > 100) {
|
|
print STDERR "Warning: more than 100 marcos ($n in your case): Don't forget to adjust var dbTemplateMaxVars\n";
|
|
}
|
|
while (1) {
|
|
local %subst = %global;
|
|
expect "{|} '{' or '}'";
|
|
last if $_ eq "}";
|
|
foreach my $macro (@macros) {
|
|
expect "$STRING|$SUBST|, value for $macro";
|
|
if ($_ eq ",") {expect "$STRING|$SUBST value for $macro";}
|
|
$subst{$macro} = $_;
|
|
}
|
|
expect "}";
|
|
eval {parseTemplate $filename} or die "$@called from $ARGV:$.\n";
|
|
};
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
sub parseFiles {
|
|
foreach (@_) {
|
|
local *ARGV;
|
|
local %global;
|
|
local %subst;
|
|
my $filename = findFile $_ or die "file $_ not found\n";
|
|
@ARGV = $filename;
|
|
if (peekToken =~ "file|global") {
|
|
while (parseSubst) {};
|
|
} else {
|
|
parseTemplate;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub printline {
|
|
if (!$show_lines) { return; }
|
|
my $line = shift;
|
|
our $oldline;
|
|
if ($line != $oldline+1) {
|
|
my $d = $line - $oldline - 1;
|
|
if ($d > 0 && $d < 3) {
|
|
print substr("\n\n\n",1,$d);
|
|
} else {
|
|
print "# line $line\n";
|
|
}
|
|
}
|
|
$oldline = $line;
|
|
}
|
|
|
|
sub handleRecord {
|
|
my $rtype = shift;
|
|
my $rname = shift;
|
|
my $line = shift;
|
|
printline $line;
|
|
print "record($rtype,\"$rname\") {";
|
|
while (@_) {
|
|
my $fieldname = shift;
|
|
my $value = shift;
|
|
my $line = shift;
|
|
print "\n";
|
|
printline $line;
|
|
print "\t\tfield($fieldname, \"$value\")";
|
|
}
|
|
print "}\n";
|
|
}
|
|
|
|
sub handleAlias {
|
|
my $rname = shift;
|
|
my $alias = shift;
|
|
my $line = shift;
|
|
printline $line;
|
|
print "alias(\"$rname\",\"$alias\")\n";
|
|
}
|
|
|
|
parseFiles @ARGV
|