Merged compiled-dbd branch.
This does all DBD-file processing at build-time in Perl scripts. The result should behave almost identically to the old programs.
This commit is contained in:
Andrew Johnson
@@ -0,0 +1,101 @@
|
||||
#*************************************************************************
|
||||
# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
|
||||
# National Laboratory.
|
||||
# EPICS BASE is distributed subject to a Software License Agreement found
|
||||
# in file LICENSE that is included with this distribution.
|
||||
#*************************************************************************
|
||||
|
||||
# $Id$
|
||||
|
||||
package EPICS::Readfile;
|
||||
require 5.000;
|
||||
require Exporter;
|
||||
|
||||
use EPICS::macLib;
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(@inputfiles &Readfile);
|
||||
|
||||
our $debug=0;
|
||||
our @inputfiles;
|
||||
|
||||
sub slurp {
|
||||
my ($FILE, $Rpath) = @_;
|
||||
my @path = @{$Rpath};
|
||||
print "slurp($FILE):\n" if $debug;
|
||||
if ($FILE !~ m[/]) {
|
||||
foreach $dir (@path) {
|
||||
print " trying $dir/$FILE\n" if $debug;
|
||||
if (-r "$dir/$FILE") {
|
||||
$FILE = "$dir/$FILE";
|
||||
last;
|
||||
}
|
||||
}
|
||||
die "Can't find file '$FILE'\n" unless -r $FILE;
|
||||
}
|
||||
print " opening $FILE\n" if $debug;
|
||||
open FILE, "<$FILE" or die "Can't open $FILE: $!\n";
|
||||
push @inputfiles, $FILE;
|
||||
my @lines = ("##!BEGIN{$FILE}!##\n");
|
||||
# Consider replacing these markers with C pre-processor linemarkers.
|
||||
# See 'info cpp' * Preprocessor Output:: for details.
|
||||
push @lines, <FILE>;
|
||||
push @lines, "##!END{$FILE}!##\n";
|
||||
close FILE or die "Error closing $FILE: $!\n";
|
||||
print " read ", scalar @lines, " lines\n" if $debug;
|
||||
return join '', @lines;
|
||||
}
|
||||
|
||||
sub expandMacros {
|
||||
my ($macros, $input) = @_;
|
||||
return $input unless $macros;
|
||||
return $macros->expandString($input);
|
||||
}
|
||||
|
||||
sub splitPath {
|
||||
my ($path) = @_;
|
||||
my (@path) = split /[:;]/, $path;
|
||||
grep s/^$/./, @path;
|
||||
return @path;
|
||||
}
|
||||
|
||||
my $RXstr = qr/ " (?: [^"] | \\" )* "/ox;
|
||||
my $RXnam = qr/[a-zA-Z0-9_\-:.[\]<>;]+/o;
|
||||
my $string = qr/ ( $RXnam | $RXstr ) /ox;
|
||||
|
||||
sub unquote {
|
||||
my ($s) = @_;
|
||||
$s =~ s/^"(.*)"$/$1/o;
|
||||
return $s;
|
||||
}
|
||||
|
||||
sub Readfile {
|
||||
my ($file, $macros, $Rpath) = @_;
|
||||
print "Readfile($file)\n" if $debug;
|
||||
my $input = &expandMacros($macros, &slurp($file, $Rpath));
|
||||
my @input = split /\n/, $input;
|
||||
my @output;
|
||||
foreach (@input) {
|
||||
if (m/^ \s* include \s+ $string /ox) {
|
||||
$arg = &unquote($1);
|
||||
print " include $arg\n" if $debug;
|
||||
push @output, "##! include \"$arg\"";
|
||||
push @output, &Readfile($arg, $macros, $Rpath);
|
||||
} elsif (m/^ \s* addpath \s+ $string /ox) {
|
||||
$arg = &unquote($1);
|
||||
print " addpath $arg\n" if $debug;
|
||||
push @output, "##! addpath \"$arg\"";
|
||||
push @{$Rpath}, &splitPath($arg);
|
||||
} elsif (m/^ \s* path \s+ $string /ox) {
|
||||
$arg = &unquote($1);
|
||||
print " path $arg\n" if $debug;
|
||||
push @output, "##! path \"$arg\"";
|
||||
@{$Rpath} = &splitPath($arg);
|
||||
} else {
|
||||
push @output, $_;
|
||||
}
|
||||
}
|
||||
return join "\n", @output;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,251 @@
|
||||
#*************************************************************************
|
||||
# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
|
||||
# National Laboratory.
|
||||
# EPICS BASE is distributed subject to a Software License Agreement found
|
||||
# in file LICENSE that is included with this distribution.
|
||||
#*************************************************************************
|
||||
|
||||
# $Id$
|
||||
|
||||
package EPICS::macLib::entry;
|
||||
|
||||
sub new ($$) {
|
||||
my $class = shift;
|
||||
my $this = {
|
||||
name => shift,
|
||||
type => shift,
|
||||
raw => '',
|
||||
val => '',
|
||||
visited => 0,
|
||||
error => 0,
|
||||
};
|
||||
bless $this, $class;
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub report ($) {
|
||||
my ($this) = @_;
|
||||
return unless defined $this->{raw};
|
||||
printf "%1s %-16s %-16s %s\n",
|
||||
($this->{error} ? '*' : ' '), $this->{name}, $this->{raw}, $this->{val};
|
||||
}
|
||||
|
||||
|
||||
package EPICS::macLib;
|
||||
|
||||
use Carp;
|
||||
|
||||
sub new ($@) {
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $this = {
|
||||
dirty => 0,
|
||||
noWarn => 0,
|
||||
macros => [{}], # [0] is current scope, [1] is parent etc.
|
||||
};
|
||||
bless $this, $class;
|
||||
$this->installList(@_);
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub installList ($@) {
|
||||
# Argument is a list of strings which are arguments to installMacros
|
||||
my $this = shift;
|
||||
while (@_) {
|
||||
$this->installMacros(shift);
|
||||
}
|
||||
}
|
||||
|
||||
sub installMacros ($$) {
|
||||
# Argument is a string: a=1,b="2",c,d='hello'
|
||||
my $this = shift;
|
||||
$_ = shift;
|
||||
until (defined pos($_) and pos($_) == length($_)) {
|
||||
m/\G \s* /xgc; # Skip whitespace
|
||||
if (m/\G ( [A-Za-z0-9_-]+ ) \s* /xgc) {
|
||||
my ($name, $val) = ($1);
|
||||
if (m/\G = \s* /xgc) {
|
||||
# The value follows, handle quotes and escapes
|
||||
until (pos($_) == length($_)) {
|
||||
if (m/\G , /xgc) { last; }
|
||||
elsif (m/\G ' ( ( [^'] | \\ ' )* ) ' /xgc) { $val .= $1; }
|
||||
elsif (m/\G " ( ( [^"] | \\ " )* ) " /xgc) { $val .= $1; }
|
||||
elsif (m/\G \\ ( . ) /xgc) { $val .= $1; }
|
||||
elsif (m/\G ( . ) /xgc) { $val .= $1; }
|
||||
else { die "How did I get here?"; }
|
||||
}
|
||||
$this->putValue($name, $val);
|
||||
} elsif (m/\G , /xgc or (pos($_) == length($_))) {
|
||||
$this->putValue($name, undef);
|
||||
} else {
|
||||
warn "How did I get here?";
|
||||
}
|
||||
} elsif (m/\G ( .* )/xgc) {
|
||||
croak "Can't find a macro definition in '$1'";
|
||||
} else {
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub putValue ($$$) {
|
||||
my ($this, $name, $raw) = @_;
|
||||
if (exists $this->{macros}[0]{$name}) {
|
||||
if (!defined $raw) {
|
||||
delete $this->{macros}[0]{$name};
|
||||
} else {
|
||||
$this->{macros}[0]{$name}{raw} = $raw;
|
||||
}
|
||||
} else {
|
||||
my $entry = EPICS::macLib::entry->new($name, 'macro');
|
||||
$entry->{raw} = $raw;
|
||||
$this->{macros}[0]{$name} = $entry;
|
||||
}
|
||||
$this->{dirty} = 1;
|
||||
}
|
||||
|
||||
sub pushScope ($) {
|
||||
my ($this) = @_;
|
||||
unshift @{$this->{macros}}, {};
|
||||
}
|
||||
|
||||
sub popScope ($) {
|
||||
my ($this) = @_;
|
||||
shift @{$this->{macros}};
|
||||
}
|
||||
|
||||
sub suppressWarning($$) {
|
||||
my ($this, $suppress) = @_;
|
||||
$this->{noWarn} = $suppress;
|
||||
}
|
||||
|
||||
sub expandString($$) {
|
||||
my ($this, $src) = @_;
|
||||
$this->_expand;
|
||||
my $entry = EPICS::macLib::entry->new($src, 'string');
|
||||
my $result = $this->_translate($entry, 0, $src);
|
||||
return $result unless $entry->{error};
|
||||
return $this->{noWarn} ? $result : undef;
|
||||
}
|
||||
|
||||
sub reportMacros ($) {
|
||||
my ($this) = @_;
|
||||
$this->_expand;
|
||||
print "Macro report\n============\n";
|
||||
foreach my $scope (@{$this->{macros}}) {
|
||||
foreach my $name (keys %{$scope}) {
|
||||
my $entry = $scope->{$name};
|
||||
$entry->report;
|
||||
}
|
||||
} continue {
|
||||
print " -- scope ends --\n";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Private routines, not intended for public use
|
||||
|
||||
sub _expand ($) {
|
||||
my ($this) = @_;
|
||||
return unless $this->{dirty};
|
||||
foreach my $scope (@{$this->{macros}}) {
|
||||
foreach my $name (keys %{$scope}) {
|
||||
my $entry = $scope->{$name};
|
||||
$entry->{val} = $this->_translate($entry, 1, $entry->{raw});
|
||||
}
|
||||
}
|
||||
$this->{dirty} = 0;
|
||||
}
|
||||
|
||||
sub _lookup ($$$$$) {
|
||||
my ($this, $name) = @_;
|
||||
foreach my $scope (@{$this->{macros}}) {
|
||||
if (exists $scope->{$name}) {
|
||||
return undef # Macro marked as deleted
|
||||
unless defined $scope->{$name}{raw};
|
||||
return $scope->{$name};
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub _translate ($$$$) {
|
||||
my ($this, $entry, $level, $str) = @_;
|
||||
return $this->_trans($entry, $level, '', \$str);
|
||||
}
|
||||
|
||||
sub _trans ($$$$$) {
|
||||
my ($this, $entry, $level, $term, $R) = @_;
|
||||
return $$R
|
||||
if (!defined $$R or
|
||||
$$R =~ m/\A [^\$]* \Z/x); # Short-circuit if no macros
|
||||
my $quote = 0;
|
||||
my $val;
|
||||
until (defined pos($$R) and pos($$R) == length($$R)) {
|
||||
if ($term and ($$R =~ m/\G (?= [$term] ) /xgc)) {
|
||||
last;
|
||||
}
|
||||
if ($$R =~ m/\G \$ ( [({] ) /xgc) {
|
||||
my $macEnd = $1;
|
||||
$macEnd =~ tr/({/)}/;
|
||||
my $name2 = $this->_trans($entry, $level+1, "=$macEnd", $R);
|
||||
my $entry2 = $this->_lookup($name2);
|
||||
if (!defined $entry2) { # Macro not found
|
||||
if ($$R =~ m/\G = /xgc) { # Use default value given
|
||||
$val .= $this->_trans($entry, $level+1, $macEnd, $R);
|
||||
} else {
|
||||
unless ($this->{noWarn}) {
|
||||
$entry->{error} = 1;
|
||||
printf STDERR "macLib: macro '%s' is undefined (expanding %s '%s')\n",
|
||||
$name2, $entry->{type}, $entry->{name};
|
||||
}
|
||||
$val .= "\$($name2)";
|
||||
}
|
||||
$$R =~ m/\G [$macEnd] /xgc; # Discard close bracket
|
||||
} else { # Macro found
|
||||
if ($entry2->{visited}) {
|
||||
$entry->{error} = 1;
|
||||
printf STDERR "macLib: %s '%s' is recursive (expanding %s '%s')\n",
|
||||
$entry->{type}, $entry->{name}, $entry2->{type}, $entry2->{name};
|
||||
$val .= "\$($name)";
|
||||
} else {
|
||||
if ($$R =~ m/\G = /xgc) { # Discard default value
|
||||
local $this->{noWarn} = 1; # Temporarily kill warnings
|
||||
$this->_trans($entry, $level+1, $macEnd, $R);
|
||||
}
|
||||
$$R =~ m/\G [$macEnd] /xgc; # Discard close bracket
|
||||
if ($this->{dirty}) { # Translate raw value
|
||||
$entry2->{visited} = 1;
|
||||
$val .= $this->_trans($entry, $level+1, '', \$entry2->{raw});
|
||||
$entry2->{visited} = 0;
|
||||
} else {
|
||||
$val .= $entry2->{val}; # Here's one I made earlier...
|
||||
}
|
||||
}
|
||||
}
|
||||
} elsif ($level > 0) { # Discard quotes and escapes
|
||||
if ($quote and $$R =~ m/\G $quote /xgc) {
|
||||
$quote = 0;
|
||||
} elsif ($$R =~ m/\G ( ['"] ) /xgc) {
|
||||
$quote = $1;
|
||||
} elsif ($$R =~ m/\G \\? ( . ) /xgc) {
|
||||
$val .= $1;
|
||||
} else {
|
||||
warn "How did I get here? level=$level";
|
||||
}
|
||||
} else { # Level 0
|
||||
if ($$R =~ m/\G \\ ( . ) /xgc) {
|
||||
$val .= "\\$1";
|
||||
} elsif ($$R =~ m/\G ( [^\\\$'")}]* ) /xgc) {
|
||||
$val .= $1;
|
||||
} elsif ($$R =~ m/\G ( . ) /xgc) {
|
||||
$val .= $1;
|
||||
} else {
|
||||
warn "How did I get here? level=$level";
|
||||
}
|
||||
}
|
||||
}
|
||||
return $val;
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user