3c99391d93
In some cases the license-identification header was missing, so I added that as well. Replaced the remaining headers that specifically identified "Versions 3.13.7 and higher". Makefiles and the build system were deliberately excluded.
252 lines
7.7 KiB
Perl
252 lines
7.7 KiB
Perl
#*************************************************************************
|
|
# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
|
|
# National Laboratory.
|
|
# SPDX-License-Identifier: EPICS
|
|
# 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;
|