251 lines
7.7 KiB
Perl
251 lines
7.7 KiB
Perl
#*************************************************************************
|
|
# 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.
|
|
#*************************************************************************
|
|
|
|
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 $name = $src) =~ s/^ (.{20}) .* $/$1.../xs;
|
|
my $entry = EPICS::macLib::entry->new($name, '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;
|