Move macLib.pm and macLib.plt here
Use @TOP@ in macLib.plt library path
This commit is contained in:
Andrew Johnson
250
src/macLib/EPICS/macLib.pm
Normal file
250
src/macLib/EPICS/macLib.pm
Normal file
@@ -0,0 +1,250 @@
|
||||
#*************************************************************************
|
||||
# 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;
|
||||
@@ -12,3 +12,5 @@ INC += macLib.h
|
||||
Com_SRCS += macCore.c
|
||||
Com_SRCS += macEnv.c
|
||||
Com_SRCS += macUtil.c
|
||||
|
||||
PERL_MODULES += EPICS/macLib.pm
|
||||
|
||||
@@ -187,6 +187,9 @@ macLibTest_SRCS += macLibTest.c
|
||||
testHarness_SRCS += macLibTest.c
|
||||
TESTS += macLibTest
|
||||
|
||||
# Perl module tests:
|
||||
TESTS += macLib
|
||||
|
||||
TESTPROD_HOST += taskwdTest
|
||||
taskwdTest_SRCS += taskwdTest.c
|
||||
testHarness_SRCS += taskwdTest.c
|
||||
|
||||
79
test/macLib.plt
Normal file
79
test/macLib.plt
Normal file
@@ -0,0 +1,79 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use lib '@TOP@/lib/perl';
|
||||
|
||||
use Test::More tests => 35;
|
||||
|
||||
use EPICS::macLib;
|
||||
|
||||
use Data::Dumper;
|
||||
|
||||
my $m = EPICS::macLib->new;
|
||||
isa_ok $m, 'EPICS::macLib';
|
||||
is $m->expandString(''), '', 'Empty string';
|
||||
|
||||
{
|
||||
local *STDERR;
|
||||
my $output;
|
||||
open STDERR, '>', \$output;
|
||||
is $m->expandString('$(undef)'), undef, 'Warning $(undef)';
|
||||
chomp $output;
|
||||
is $output, q/macLib: macro 'undef' is undefined (expanding string '$(undef)')/, 'macLib error message';
|
||||
}
|
||||
|
||||
$m->suppressWarning(1);
|
||||
is $m->expandString('$(undef)'), '$(undef)', 'Suppressed $(undef)';
|
||||
|
||||
$m->putValue('a', 'foo');
|
||||
is $m->expandString('$(a)'), 'foo', '$(a)';
|
||||
is $m->expandString('${a}'), 'foo', '${a}';
|
||||
is $m->expandString('$(a=bar)'), 'foo', '$(a=bar)';
|
||||
is $m->expandString('${a=bar}'), 'foo', '${a=bar}';
|
||||
is $m->expandString('$(undef)'), '$(undef)', '$(undef) again';
|
||||
is $m->expandString('${undef}'), '$(undef)', '${undef} again';
|
||||
|
||||
$m->suppressWarning(0);
|
||||
is $m->expandString('$(undef=$(a))'), 'foo', '$(undef=$(a))';
|
||||
is $m->expandString('${undef=${a}}'), 'foo', '${undef=${a}}';
|
||||
is $m->expandString('${undef=$(a)}'), 'foo', '${undef=$(a)}';
|
||||
is $m->expandString('$(undef=${a})'), 'foo', '$(undef=${a})';
|
||||
is $m->expandString('$(a=$(undef))'), 'foo', '$(a=$(undef))';
|
||||
|
||||
$m->putValue('b', 'baz');
|
||||
is $m->expandString('$(b)'), 'baz', '$(b)';
|
||||
is $m->expandString('$(a)'), 'foo', '$(a)';
|
||||
is $m->expandString('$(a)$(b)'), 'foobaz', '$(a)$(b)';
|
||||
is $m->expandString('$(a)/$(b)'), 'foo/baz', '$(a)/$(b)';
|
||||
is $m->expandString('$(a)\$(b)'), 'foo\$(b)', '$(a)\$(b)';
|
||||
is $m->expandString('$(a)$$(b)'), 'foo$baz', '$(a)$$(b)';
|
||||
|
||||
$m->putValue('c', '$(a)');
|
||||
is $m->expandString('$(c)'), 'foo', '$(c)';
|
||||
is $m->expandString('$(undef=$(c))'), 'foo', '$(undef=$(c))';
|
||||
|
||||
$m->putValue('d', 'c');
|
||||
is $m->expandString('$(d)'), 'c', '$(d)';
|
||||
is $m->expandString('$($(d))'), 'foo', '$($(d))';
|
||||
is $m->expandString('$($(b)=$(a))'), 'foo', '$($(b)=$(a))';
|
||||
|
||||
$m->suppressWarning(1);
|
||||
$m->putValue('c', undef);
|
||||
is $m->expandString('$(c)'), '$(c)', '$(c) deleted';
|
||||
|
||||
$m->installMacros('c=fum,d');
|
||||
is $m->expandString('$(c)'), 'fum', 'installMacros, $(c)';
|
||||
|
||||
is $m->expandString('$(d)'), '$(d)', 'installMacros deletion';
|
||||
|
||||
$m->pushScope;
|
||||
is $m->expandString('$(a)'), 'foo', 'pushScope, $(a)';
|
||||
$m->putValue('a', 'grinch');
|
||||
is $m->expandString('$(a)'), 'grinch', 'new $(a) in child';
|
||||
|
||||
$m->putValue('b', undef);
|
||||
is $m->expandString('$(b)'), '$(b)', '$(b) deleted in child';
|
||||
|
||||
$m->popScope;
|
||||
is $m->expandString('$(a)'), 'foo', 'popScope, $(a) restored';
|
||||
is $m->expandString('$(b)'), 'baz', '$(b) restored';
|
||||
|
||||
Reference in New Issue
Block a user