epics/pcas
0
0
Fork 0
Code Issues Pull Requests Projects Wiki Activity

tools: Support for DB files, added dbExpand.pl

Browse Source
This commit is contained in:
Andrew Johnson
2015-07-06 11:26:35 -05:00
parent 3a54e97758
commit f6cdbe2693
19 changed files with 420 additions and 85 deletions
Download Patch File Download Diff File Expand all files Collapse all files

17
src/tools/DBD.pm
View File

@@ -1,11 +1,15 @@
package DBD;
use strict;
use warnings;
use DBD::Base;
use DBD::Breaktable;
use DBD::Driver;
use DBD::Menu;
use DBD::Recordtype;
use DBD::Recfield;
use DBD::Record;
use DBD::Registrar;
use DBD::Function;
use DBD::Variable;
@@ -20,6 +24,7 @@ sub new {
'DBD::Function' => {},
'DBD::Menu' => {},
'DBD::Recordtype' => {},
'DBD::Record' => {},
'DBD::Registrar' => {},
'DBD::Variable' => {},
'COMMENTS' => [],
@@ -30,12 +35,12 @@ sub new {
}
sub add {
my ($this, $obj) = @_;
my ($this, $obj, $obj_name) = @_;
my $obj_class = ref $obj;
confess "DBD::add: Unknown DBD object type '$obj_class'"
unless $obj_class =~ m/^DBD::/
and exists $this->{$obj_class};
my $obj_name = $obj->name;
$obj_name = $obj->name unless defined $obj_name;
if (exists $this->{$obj_class}->{$obj_name}) {
return if $obj->equals($this->{$obj_class}->{$obj_name});
dieContext("A different $obj->{WHAT} named '$obj_name' already exists");
@@ -95,6 +100,14 @@ sub recordtype {
return $this->{'DBD::Recordtype'}->{$rtyp_name};
}
sub records {
return shift->{'DBD::Record'};
}
sub record {
my ($this, $record_name) = @_;
return $this->{'DBD::Record'}->{$record_name};
}
sub registrars {
return shift->{'DBD::Registrar'};
}

31
src/tools/DBD/Base.pm
View File

@@ -2,17 +2,21 @@
package DBD::Base;
use strict;
use warnings;
use Carp;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(&pushContext &popContext &dieContext &warnContext &is_reserved
&identifier &unquote &escapeCcomment &escapeCstring $RXident $RXname
$RXuint $RXint $RXhex $RXoct $RXuintx $RXintx $RXnum $RXdqs $RXsqs $RXstr);
our @ISA = qw(Exporter);
our @EXPORT = qw(&pushContext &popContext &dieContext &warnContext &is_reserved
&escapeCcomment &escapeCstring $RXident $RXname $RXuint $RXint $RXhex $RXoct
$RXuintx $RXintx $RXnum $RXdqs $RXsqs $RXstr);
our $RXident = qr/ [a-zA-Z] [a-zA-Z0-9_]* /x;
our $RXname = qr/ [a-zA-Z0-9_\-:.<>;]+ /x;
our $RXname = qr/ [a-zA-Z0-9_\-:.\[\]<>;]+ /x;
our $RXhex = qr/ (?: 0 [xX] [0-9A-Fa-f]+ ) /x;
our $RXoct = qr/ 0 [0-7]* /x;
our $RXuint = qr/ \d+ /x;
@@ -20,8 +24,8 @@ our $RXint = qr/ -? $RXuint /ox;
our $RXuintx = qr/ ( $RXhex | $RXoct | $RXuint ) /ox;
our $RXintx = qr/ ( $RXhex | $RXoct | $RXint ) /ox;
our $RXnum = qr/ -? (?: \d+ | \d* \. \d+ ) (?: [eE] [-+]? \d+ )? /x;
our $RXdqs = qr/" (?: [^"] | \\" )* " /x;
our $RXsqs = qr/' (?: [^'] | \\' )* ' /x;
our $RXdqs = qr/ " (?: [^"] | \\" )* " /x;
our $RXsqs = qr/ ' (?: [^'] | \\' )* ' /x;
our $RXstr = qr/ ( $RXname | $RXnum | $RXdqs | $RXsqs ) /ox;
our @context;
@@ -51,14 +55,6 @@ sub warnContext {
}
# Input checking
sub unquote (\$) {
my ($s) = @_;
$$s =~ s/^"(.*)"$/$1/o;
return $$s;
}
# Reserved words from C++ and the DB/DBD file parser
my %reserved = map { $_ => undef } qw(and and_eq asm auto bitand bitor bool
break case catch char class compl const const_cast continue default delete
@@ -75,8 +71,7 @@ sub is_reserved {
}
sub identifier {
my ($id, $what) = @_;
unquote $id;
my ($this, $id, $what) = @_;
confess "DBD::Base::identifier: $what undefined!"
unless defined $id;
$id =~ m/^$RXident$/o or dieContext("Illegal $what '$id'",
@@ -115,7 +110,7 @@ sub new {
sub init {
my ($this, $name, $what) = @_;
$this->{NAME} = identifier($name, "$what name");
$this->{NAME} = $this->identifier($name, "$what name");
$this->{WHAT} = $what;
return $this;
}

12
src/tools/DBD/Breaktable.pm
View File

@@ -9,6 +9,7 @@ sub init {
$this->SUPER::init($name, "breakpoint table");
$this->{POINT_LIST} = [];
$this->{COMMENTS} = [];
$this->{POD} = [];
return $this;
}
@@ -18,8 +19,6 @@ sub add_point {
unless defined $raw;
confess "DBD::Breaktable::add_point: Engineering value undefined!"
unless defined $eng;
unquote $raw;
unquote $eng;
push @{$this->{POINT_LIST}}, [$raw, $eng];
}
@@ -41,6 +40,15 @@ sub comments {
return @{shift->{COMMENTS}};
}
sub add_pod {
my $this = shift;
push @{$this->{POD}}, @_;
}
sub pod {
return @{shift->{POD}};
}
sub equals {
my ($a, $b) = @_;
return $a->SUPER::equals($b)

2
src/tools/DBD/Device.pm
View File

@@ -18,7 +18,6 @@ my %link_types = (
sub init {
my ($this, $link_type, $dset, $choice) = @_;
unquote $choice;
dieContext("Unknown link type '$link_type', valid types are:",
sort keys %link_types) unless exists $link_types{$link_type};
$this->SUPER::init($dset, "device support (dset)");
@@ -38,7 +37,6 @@ sub choice {
sub legal_addr {
my ($this, $addr) = @_;
my $rx = $link_types{$this->{LINK_TYPE}};
unquote $addr;
return $addr =~ m/^ $rx $/x;
}

4
src/tools/DBD/Menu.pm
View File

@@ -13,8 +13,7 @@ sub init {
sub add_choice {
my ($this, $name, $value) = @_;
$name = identifier($name, "Choice name");
unquote $value;
$name = $this->identifier($name, "Choice name");
foreach $pair ($this->choices) {
dieContext("Duplicate menu choice name '$name'")
if ($pair->[0] eq $name);
@@ -36,7 +35,6 @@ sub choice {
sub legal_choice {
my ($this, $value) = @_;
unquote $value;
return exists $this->{CHOICE_INDEX}->{$value};
}

34
src/tools/DBD/Output.pm
View File

@@ -1,9 +1,12 @@
package DBD::Output;
use strict;
use warnings;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(&OutputDBD);
our @ISA = qw(Exporter);
our @EXPORT = qw(&OutputDBD &OutputDB);
use DBD;
use DBD::Base;
@@ -13,6 +16,7 @@ use DBD::Driver;
use DBD::Menu;
use DBD::Recordtype;
use DBD::Recfield;
use DBD::Record;
use DBD::Registrar;
use DBD::Function;
use DBD::Variable;
@@ -28,6 +32,11 @@ sub OutputDBD {
OutputBreaktables($out, $dbd->breaktables);
}
sub OutputDB {
my ($out, $dbd) = @_;
OutputRecords($out, $dbd->records);
}
sub OutputMenus {
my ($out, $menus) = @_;
while (my ($name, $menu) = each %{$menus}) {
@@ -44,7 +53,7 @@ sub OutputRecordtypes {
printf $out "recordtype(%s) {\n", $name;
print $out " %$_\n"
foreach $recordtype->cdefs;
foreach $field ($recordtype->fields) {
foreach my $field ($recordtype->fields) {
printf $out " field(%s, %s) {\n",
$field->name, $field->dbf_type;
while (my ($attr, $val) = each %{$field->attributes}) {
@@ -98,4 +107,23 @@ sub OutputBreaktables {
}
}
sub OutputRecords {
my ($out, $records) = @_;
while (my ($name, $rec) = each %{$records}) {
next if $name ne $rec->name; # Alias
printf $out "record(%s, \"%s\") {\n", $rec->recordtype->name, $name;
printf $out " alias(\"%s\")\n", $_
foreach $rec->aliases;
foreach my $recfield ($rec->recfields) {
my $field_name = $recfield->name;
my $value = $rec->get_field($field_name);
printf $out " field(%s, \"%s\")\n", $field_name, $value
if defined $value;
}
printf $out " info(\"%s\", \"%s\")\n", $_, $rec->info_value($_)
foreach $rec->info_names;
print $out "}\n";
}
}
1;

159
src/tools/DBD/Parser.pm
View File

@@ -1,8 +1,12 @@
package DBD::Parser;
use strict;
use warnings;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(&ParseDBD);
our @ISA = qw(Exporter);
our @EXPORT = qw(&ParseDBD);
use DBD;
use DBD::Base;
@@ -12,6 +16,7 @@ use DBD::Driver;
use DBD::Menu;
use DBD::Recordtype;
use DBD::Recfield;
use DBD::Record;
use DBD::Registrar;
use DBD::Function;
use DBD::Variable;
@@ -24,46 +29,72 @@ sub ParseDBD {
parseCommon($dbd);
if (m/\G menu \s* \( \s* $RXstr \s* \) \s* \{/oxgc) {
print "Menu: $1\n" if $debug;
parse_menu($dbd, $1);
my ($menu_name) = unquote($1);
parse_menu($dbd, $menu_name);
}
elsif (m/\G driver \s* \( \s* $RXstr \s* \)/oxgc) {
print "Driver: $1\n" if $debug;
$dbd->add(DBD::Driver->new($1));
my ($driver_name) = unquote($1);
$dbd->add(DBD::Driver->new($driver_name));
}
elsif (m/\G registrar \s* \( \s* $RXstr \s* \)/oxgc) {
print "Registrar: $1\n" if $debug;
$dbd->add(DBD::Registrar->new($1));
my ($registrar_name) = unquote($1);
$dbd->add(DBD::Registrar->new($registrar_name));
}
elsif (m/\G function \s* \( \s* $RXstr \s* \)/oxgc) {
print "Function: $1\n" if $debug;
$dbd->add(DBD::Function->new($1));
my ($function_name) = unquote($1);
$dbd->add(DBD::Function->new($function_name));
}
elsif (m/\G breaktable \s* \( \s* $RXstr \s* \) \s* \{/oxgc) {
print "Breaktable: $1\n" if $debug;
parse_breaktable($dbd, $1);
my ($breaktable_name) = unquote($1);
parse_breaktable($dbd, $breaktable_name);
}
elsif (m/\G recordtype \s* \( \s* $RXstr \s* \) \s* \{/oxgc) {
print "Recordtype: $1\n" if $debug;
parse_recordtype($dbd, $1);
my ($recordtype_name) = unquote($1);
parse_recordtype($dbd, $recordtype_name);
}
elsif (m/\G g?record \s* \( \s* $RXstr \s*, \s* $RXstr \s* \) \s* \{/oxgc) {
print "Record: $1, $2\n" if $debug;
my ($record_type, $record_name) = unquote($1, $2);
parse_record($dbd, $record_type, $record_name);
}
elsif (m/\G alias \s* \( \s* $RXstr \s*, \s* $RXstr \s* \)/oxgc) {
print "Alias: $1, $2\n" if $debug;
my ($record_name, $alias) = unquote($1, $2);
my $rec = $dbd->record($record_name);
dieContext("Alias '$alias' refers to unknown record '$record_name'")
unless defined $rec;
dieContext("Can't create alias '$alias', name already used")
if defined $dbd->record($alias);
$rec->add_alias($alias);
$dbd->add($rec, $alias);
}
elsif (m/\G variable \s* \( \s* $RXstr \s* \)/oxgc) {
print "Variable: $1\n" if $debug;
$dbd->add(DBD::Variable->new($1));
my ($variable_name) = unquote($1);
$dbd->add(DBD::Variable->new($variable_name));
}
elsif (m/\G variable \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) {
print "Variable: $1, $2\n" if $debug;
$dbd->add(DBD::Variable->new($1, $2));
my ($variable_name, $variable_type) = unquote($1, $2);
$dbd->add(DBD::Variable->new($variable_name, $variable_type));
}
elsif (m/\G device \s* \( \s* $RXstr \s* , \s* $RXstr \s* ,
\s* $RXstr \s* , \s*$RXstr \s* \)/oxgc) {
print "Device: $1, $2, $3, $4\n" if $debug;
my $rtyp = $dbd->recordtype($1);
my ($record_type, $link_type, $dset, $choice) =
unquote($1, $2, $3, $4);
my $rtyp = $dbd->recordtype($record_type);
if (!defined $rtyp) {
$rtyp = DBD::Recordtype->new($1);
warn "Device using undefined record type '$1', place-holder created\n";
$rtyp = DBD::Recordtype->new($record_type);
warn "Device using undefined record type '$record_type', place-holder created\n";
$dbd->add($rtyp);
}
$rtyp->add_device(DBD::Device->new($2, $3, $4));
$rtyp->add_device(DBD::Device->new($link_type, $dset, $choice));
} else {
last unless m/\G (.*) $/moxgc;
dieContext("Syntax error in '$1'");
@@ -101,6 +132,10 @@ sub parseCommon {
}
}
sub unquote {
return map { m/^ ("?) (.*) \1 $/ox; $2 } @_;
}
sub parsePod {
pushContext("Pod markup");
my @pod;
@@ -119,19 +154,20 @@ sub parsePod {
}
sub parse_menu {
my ($dbd, $name) = @_;
pushContext("menu($name)");
my $menu = DBD::Menu->new($name);
my ($dbd, $menu_name) = @_;
pushContext("menu($menu_name)");
my $menu = DBD::Menu->new($menu_name);
while(1) {
parseCommon($menu);
if (m/\G choice \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) {
print " Menu-Choice: $1, $2\n" if $debug;
$menu->add_choice($1, $2);
my ($choice_name, $value) = unquote($1, $2);
$menu->add_choice($choice_name, $value);
}
elsif (m/\G \}/oxgc) {
print " Menu-End:\n" if $debug;
$dbd->add($menu);
popContext("menu($name)");
popContext("menu($menu_name)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
@@ -141,23 +177,25 @@ sub parse_menu {
}
sub parse_breaktable {
my ($dbd, $name) = @_;
pushContext("breaktable($name)");
my $bt = DBD::Breaktable->new($name);
my ($dbd, $breaktable_name) = @_;
pushContext("breaktable($breaktable_name)");
my $bt = DBD::Breaktable->new($breaktable_name);
while(1) {
parseCommon($bt);
if (m/\G point\s* \(\s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) {
print " Breaktable-Point: $1, $2\n" if $debug;
$bt->add_point($1, $2);
my ($raw, $eng) = unquote($1, $2);
$bt->add_point($raw, $eng);
}
elsif (m/\G $RXstr \s* (?: , \s*)? $RXstr (?: \s* ,)?/oxgc) {
print " Breaktable-Data: $1, $2\n" if $debug;
$bt->add_point($1, $2);
my ($raw, $eng) = unquote($1, $2);
$bt->add_point($raw, $eng);
}
elsif (m/\G \}/oxgc) {
print " Breaktable-End:\n" if $debug;
$dbd->add($bt);
popContext("breaktable($name)");
popContext("breaktable($breaktable_name)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
@@ -167,24 +205,64 @@ sub parse_breaktable {
}
sub parse_recordtype {
my ($dbd, $name) = @_;
pushContext("recordtype($name)");
my $rtyp = DBD::Recordtype->new($name);
my ($dbd, $record_type) = @_;
pushContext("recordtype($record_type)");
my $rtyp = DBD::Recordtype->new($record_type);
while(1) {
parseCommon($rtyp);
if (m/\G field \s* \( \s* $RXstr \s* , \s* $RXstr \s* \) \s* \{/oxgc) {
print " Recordtype-Field: $1, $2\n" if $debug;
parse_field($rtyp, $1, $2);
}
elsif (m/\G \}/oxgc) {
print " Recordtype-End:\n" if $debug;
$dbd->add($rtyp);
popContext("recordtype($name)");
return;
my ($field_name, $field_type) = unquote($1, $2);
parse_field($rtyp, $field_name, $field_type);
}
elsif (m/\G % (.*) \n/oxgc) {
print " Recordtype-Cdef: $1\n" if $debug;
$rtyp->add_cdef($1);
}
elsif (m/\G \}/oxgc) {
print " Recordtype-End:\n" if $debug;
$dbd->add($rtyp);
popContext("recordtype($record_type)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
sub parse_record {
my ($dbd, $record_type, $record_name) = @_;
pushContext("record($record_type, $record_name)");
my $rtyp = $dbd->recordtype($record_type);
dieContext("No recordtype named '$record_type'")
unless defined $rtyp;
my $rec = DBD::Record->new($rtyp, $record_name); # FIXME: Merge duplicates
while(1) {
parseCommon($rec);
if (m/\G field \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) {
print " Record-Field: $1, $2\n" if $debug;
my ($field_name, $value) = unquote($1, $2);
$rec->put_field($field_name, $value);
}
elsif (m/\G info \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) {
print " Record-Info: $1, $2\n" if $debug;
my ($info_name, $value) = unquote($1, $2);
$rec->add_info($info_name, $value);
}
elsif (m/\G alias \s* \( \s* $RXstr \s* \)/oxgc) {
print " Record-Alias: $1\n" if $debug;
my ($alias) = unquote($1);
dieContext("Can't create alias '$alias', name in use")
if defined $dbd->record($1);
$rec->add_alias($alias);
$dbd->add($rec, $alias);
}
elsif (m/\G \}/oxgc) {
print " Record-End:\n" if $debug;
$dbd->add($rec);
popContext("record($record_type, $record_name)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
@@ -193,19 +271,20 @@ sub parse_recordtype {
}
sub parse_field {
my ($rtyp, $name, $field_type) = @_;
my $fld = DBD::Recfield->new($name, $field_type);
pushContext("field($name, $field_type)");
my ($rtyp, $field_name, $field_type) = @_;
my $fld = DBD::Recfield->new($field_name, $field_type);
pushContext("field($field_name, $field_type)");
while(1) {
parseCommon($fld);
if (m/\G (\w+) \s* \( \s* $RXstr \s* \)/oxgc) {
print " Field-Attribute: $1, $2\n" if $debug;
$fld->add_attribute($1, $2);
my ($attr, $value) = unquote($1, $2);
$fld->add_attribute($attr, $value);
}
elsif (m/\G \}/oxgc) {
print " Field-End:\n" if $debug;
$rtyp->add_field($fld);
popContext("field($name, $field_type)");
popContext("field($field_name, $field_type)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");

2
src/tools/DBD/Recfield.pm
View File

@@ -50,7 +50,6 @@ sub new {
sub init {
my ($this, $name, $type) = @_;
unquote $type;
$this->SUPER::init($name, "record field");
dieContext("Illegal field type '$type', valid field types are:",
sort keys %field_types) unless exists $field_types{$type};
@@ -75,7 +74,6 @@ sub number {
sub add_attribute {
my ($this, $attr, $value) = @_;
unquote $value;
my $match = $field_attrs{$attr};
if (defined $match) {
dieContext("Bad value '$value' for field attribute '$attr'")

123
src/tools/DBD/Record.pm Normal file
View File

@@ -0,0 +1,123 @@
package DBD::Record;
use strict;
use warnings;
use DBD::Base;
our @ISA = qw(DBD::Base);
use Carp;
our ($macrosOk);
my $warned;
sub init {
my ($this, $type, $name) = @_;
confess "DBD::Record::init: Not a DBD::Recordtype"
unless $type->isa('DBD::Recordtype');
$this->SUPER::init($name, "record");
$this->{RECORD_TYPE} = $type;
$this->{ALIASES} = [];
$this->{RECFIELD_LIST} = [];
$this->{FIELD_INDEX} = {};
$this->{INFO_LIST} = [];
$this->{INFO_ITEMS} = {};
$this->{COMMENTS} = [];
$this->{POD} = [];
return $this;
}
# Override, record names are not as strict as recordtype and menu names
sub identifier {
my ($this, $id, $what) = @_;
confess "DBD::Record::identifier: $what undefined!"
unless defined $id;
if ($macrosOk) {
# FIXME - Check name with macro
}
elsif ($id !~ m/^$RXname$/o) {
my @message;
push @message, "A $what should contain only letters, digits and these",
"special characters: _ - : . [ ] < > ;" unless $warned++;
warnContext("Deprecated $what '$id'", @message);
}
return $id;
}
sub recordtype {
return shift->{RECORD_TYPE};
}
sub add_alias {
my ($this, $alias) = @_;
push @{$this->{ALIASES}}, $this->identifier($alias, "alias name");
}
sub aliases {
return @{shift->{ALIASES}};
}
sub put_field {
my ($this, $field_name, $value) = @_;
my $recfield = $this->{RECORD_TYPE}->field($field_name);
dieContext("No field named '$field_name'")
unless defined $recfield;
dieContext("Can't set $field_name to '$value'")
unless $recfield->legal_value($value);
push @{$this->{RECFIELD_LIST}}, $recfield
unless exists $this->{FIELD_INDEX}->{$field_name};
$this->{FIELD_INDEX}->{$field_name} = $value;
}
sub recfields {
return @{shift->{RECFIELD_LIST}};
}
sub field_names { # In their original order...
return map {$_->name} @{shift->{RECFIELD_LIST}};
}
sub get_field {
my ($this, $field_name) = @_;
return $this->{FIELD_INDEX}->{$field_name}
if exists $this->{FIELD_INDEX}->{$field_name};
my $recfield = $this->{RECORD_TYPE}->field($field_name);
return $recfield->attribute("initial");
}
sub add_info {
my ($this, $info_name, $value) = @_;
push @{$this->{INFO_LIST}}, $info_name
unless exists $this->{INFO_ITEMS}->{$info_name};
$this->{INFO_ITEMS}->{$info_name} = $value;
}
sub info_names {
return @{shift->{INFO_LIST}};
}
sub info_value {
my ($this, $info_name) = @_;
return $this->{INFO_ITEMS}->{$info_name};
}
sub add_comment {
my ($this, $comment) = @_;
push @{$this->{COMMENTS}}, $comment;
}
sub comments {
return @{shift->{COMMENTS}};
}
sub add_pod {
my $this = shift;
push @{$this->{POD}}, @_;
}
sub pod {
return @{shift->{POD}};
}
1;

6
src/tools/DBD/Variable.pm
View File

@@ -10,11 +10,7 @@ my %valid_types = (
sub init {
my ($this, $name, $type) = @_;
if (defined $type) {
unquote $type;
} else {
$type = "int";
}
$type = "int" unless defined $type;
exists $valid_types{$type} or
dieContext("Unknown variable type '$type', valid types are:",
sort keys %valid_types);

3
src/tools/EPICS/macLib.pm
View File

@@ -122,7 +122,8 @@ sub suppressWarning($$) {
sub expandString($$) {
my ($this, $src) = @_;
$this->_expand;
my $entry = EPICS::macLib::entry->new($src, 'string');
(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;

2
src/tools/Makefile
View File

@@ -29,6 +29,7 @@ PERL_MODULES += DBD/Output.pm
PERL_MODULES += DBD/Parser.pm
PERL_MODULES += DBD/Recfield.pm
PERL_MODULES += DBD/Recordtype.pm
PERL_MODULES += DBD/Record.pm
PERL_MODULES += DBD/Registrar.pm
PERL_MODULES += DBD/Variable.pm
@@ -49,6 +50,7 @@ PERL_SCRIPTS += useManifestTool.pl
PERL_SCRIPTS += dbdToMenuH.pl
PERL_SCRIPTS += dbdToRecordtypeH.pl
PERL_SCRIPTS += dbdExpand.pl
PERL_SCRIPTS += dbExpand.pl
PERL_SCRIPTS += dbdToHtml.pl
PERL_SCRIPTS += podToHtml.pl
PERL_SCRIPTS += podRemove.pl

88
src/tools/dbExpand.pl Normal file
View File

@@ -0,0 +1,88 @@
#!/usr/bin/env 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.
#*************************************************************************
# $Id$
use strict;
use FindBin qw($Bin);
use lib "$Bin/../../lib/perl";
use DBD;
use DBD::Parser;
use DBD::Output;
use EPICS::Getopts;
use EPICS::Readfile;
use EPICS::macLib;
our ($opt_D, @opt_I, @opt_S, $opt_o, $opt_V);
getopts('DI@S@o:V') or
die "Usage: dbExpand [-D] [-I dir] [-S macro=val] [-o out.db] in.dbd in.db ...";
my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
my $macros = EPICS::macLib->new(@opt_S);
my $dbd = DBD->new();
$macros->suppressWarning(!$opt_V);
$DBD::Record::macrosOk = !$opt_V;
# Calculate filename for the dependency warning message below
my $dep = $opt_o;
my $dot_d = '';
if ($opt_D) {
$dep =~ s{\.\./O\.Common/(.*)}{$1\$\(DEP\)};
$dot_d = '.d';
} else {
$dep = "\$(COMMON_DIR)/$dep";
}
die "dbExpand.pl: No input files for $opt_o\n" if !@ARGV;
my $errors = 0;
while (@ARGV) {
my $file = shift @ARGV;
eval {
&ParseDBD($dbd, &Readfile($file, $macros, \@opt_I));
};
if ($@) {
warn "dbExpand.pl: $@";
my $outfile = $opt_o ? " to create '$opt_o$dot_d'" : '';
warn " while reading '$file'$outfile\n";
warn " Your Makefile may need this dependency rule:\n",
" $dep: \$(COMMON_DIR)/$file\n"
if $@ =~ m/Can't find file '$file'/;
++$errors;
}
}
if ($opt_D) { # Output dependencies only, ignore errors
my %filecount;
my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
print "$opt_o: ", join(" \\\n ", @uniqfiles), "\n\n";
print map { "$_:\n" } @uniqfiles;
exit 0;
}
die "dbExpand.pl: Exiting due to errors\n" if $errors;
my $out;
if ($opt_o) {
open $out, '>', $opt_o or die "Can't create $opt_o: $!\n";
} else {
$out = *STDOUT;
}
&OutputDB($out, $dbd);
if ($opt_o) {
close $out or die "Closing $opt_o failed: $!\n";
}
exit 0;

8
src/tools/dbdExpand.pl Executable file → Normal file
View File

@@ -1,4 +1,4 @@
#!/usr/bin/perl
#!/usr/bin/env perl
#*************************************************************************
# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
@@ -9,6 +9,8 @@
# $Id$
use strict;
use FindBin qw($Bin);
use lib "$Bin/../../lib/perl";
@@ -19,6 +21,8 @@ use EPICS::Getopts;
use EPICS::Readfile;
use EPICS::macLib;
our ($opt_D, @opt_I, @opt_S, $opt_o);
getopts('DI@S@o:') or
die "Usage: dbdExpand [-D] [-I dir] [-S macro=val] [-o out.dbd] in.dbd ...";
@@ -69,7 +73,7 @@ my $out;
if ($opt_o) {
open $out, '>', $opt_o or die "Can't create $opt_o: $!\n";
} else {
$out = STDOUT;
$out = *STDOUT;
}
OutputDBD($out, $dbd);

6
src/tools/dbdReport.pl Executable file → Normal file
View File

@@ -32,7 +32,7 @@ my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
my $macros = EPICS::macLib->new(@opt_S);
my $dbd = DBD->new();
ParseDBD($dbd, Readfile(shift @ARGV, $macros, \@opt_I));
ParseDBD($dbd, Readfile(shift @ARGV, $macros, \@opt_I)) while @ARGV;
$Text::Wrap::columns = 75;
@@ -62,3 +62,7 @@ if (%recordtypes) {
if @devices;
}
}
my @records = sort keys %{$dbd->records};
print wrap("Records: ", "\t", join(', ', @records)), "\n"
if @records;

0
src/tools/dbdToMenuH.pl Executable file → Normal file
View File

0
src/tools/dbdToRecordtypeH.pl Executable file → Normal file
View File

4
src/tools/test/Device.plt
View File

@@ -7,7 +7,7 @@ use Test::More tests => 16;
use DBD::Device;
my $dev = DBD::Device->new('VME_IO', 'test', '"Device"');
my $dev = DBD::Device->new('VME_IO', 'test', 'Device');
isa_ok $dev, 'DBD::Device';
is $dev->name, 'test', 'Device name';
is $dev->link_type, 'VME_IO', 'Link type';
@@ -27,7 +27,7 @@ my %dev_addrs = (
INST_IO => '@Anything'
);
while (my ($link, $addr) = each(%dev_addrs)) {
$dev->init($link, 'test', '"Device"');
$dev->init($link, 'test', 'Device');
ok $dev->legal_addr($addr), "$link address";
}

4
src/tools/test/Menu.plt
View File

@@ -11,11 +11,11 @@ my $menu = DBD::Menu->new('test');
isa_ok $menu, 'DBD::Menu';
is $menu->name, 'test', 'Menu name';
is $menu->choices, 0, 'Choices == zero';
$menu->add_choice('ch1', '"Choice 1"');
$menu->add_choice('ch1', 'Choice 1');
is $menu->choices, 1, 'First choice added';
ok $menu->legal_choice('Choice 1'), 'First choice legal';
is_deeply $menu->choice(0), ['ch1', 'Choice 1'], 'First choice found';
$menu->add_choice('ch2', '"Choice 2"');
$menu->add_choice('ch2', 'Choice 2');
is $menu->choices, 2, 'Second choice added';
ok $menu->legal_choice('Choice 1'), 'First choice still legal';
is_deeply $menu->choice(0), ['ch1', 'Choice 1'], 'First choice still found';