epics/epics-base
0
0
Fork 0
Code Issues Pull Requests Projects Wiki Activity

Move all under modules/database

Browse Source
This commit is contained in:
Ralph Lange
2018-06-19 11:31:13 +02:00
parent e613d685fd
commit 568c405165
562 changed files with 0 additions and 101 deletions
Download Patch File Download Diff File Expand all files Collapse all files
modules/database/src/tools/DBD.pm
+125
View File
@@ -0,0 +1,125 @@
package DBD;
use strict;
use warnings;
use DBD::Base;
use DBD::Breaktable;
use DBD::Driver;
use DBD::Link;
use DBD::Menu;
use DBD::Recordtype;
use DBD::Recfield;
use DBD::Record;
use DBD::Registrar;
use DBD::Function;
use DBD::Variable;
use Carp;
sub new {
my ($class) = @_;
my $this = {
'DBD::Breaktable' => {},
'DBD::Driver' => {},
'DBD::Link' => {},
'DBD::Function' => {},
'DBD::Menu' => {},
'DBD::Recordtype' => {},
'DBD::Record' => {},
'DBD::Registrar' => {},
'DBD::Variable' => {},
'COMMENTS' => [],
'POD' => []
};
bless $this, $class;
return $this;
}
sub add {
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};
$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");
}
else {
$this->{$obj_class}->{$obj_name} = $obj;
}
}
sub add_comment {
my $this = shift;
push @{$this->{COMMENTS}}, @_;
}
sub comments {
return @{shift->{COMMENTS}};
}
sub add_pod {
my $this = shift;
push @{$this->{POD}}, @_;
}
sub pod {
return @{shift->{POD}};
}
sub breaktables {
return shift->{'DBD::Breaktable'};
}
sub breaktable {
my ($this, $name) = @_;
return $this->{'DBD::Breaktable'}->{$name};
}
sub drivers {
return shift->{'DBD::Driver'};
}
sub links {
return shift->{'DBD::Link'};
}
sub functions {
return shift->{'DBD::Function'};
}
sub menus {
return shift->{'DBD::Menu'};
}
sub menu {
my ($this, $menu_name) = @_;
return $this->{'DBD::Menu'}->{$menu_name};
}
sub recordtypes {
return shift->{'DBD::Recordtype'};
}
sub recordtype {
my ($this, $rtyp_name) = @_;
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'};
}
sub variables {
return shift->{'DBD::Variable'};
}
1;
modules/database/src/tools/DBD/Base.pm
+143
View File
@@ -0,0 +1,143 @@
# Common utility functions used by the DBD components
package DBD::Base;
use strict;
use warnings;
use Carp;
require Exporter;
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 $RXstr);
our $RXident = qr/ [a-zA-Z] [a-zA-Z0-9_]* /x;
our $RXnchr = qr/ [a-zA-Z0-9_\-:.\[\]<>;] /x;
our $RXname = qr/ $RXnchr+ (?: [{}] $RXnchr+ )* /x;
our $RXhex = qr/ (?: 0 [xX] [0-9A-Fa-f]+ ) /x;
our $RXoct = qr/ 0 [0-7]* /x;
our $RXuint = qr/ [0-9]+ /x;
our $RXint = qr/ -? $RXuint /x;
our $RXuintx = qr/ ( $RXhex | $RXoct | $RXuint ) /x;
our $RXintx = qr/ ( $RXhex | $RXoct | $RXint ) /x;
our $RXnum = qr/ -? (?: [0-9]+ | [0-9]* \. [0-9]+ ) (?: [eE] [-+]? [0-9]+ )? /x;
our $RXdqs = qr/ " (?> \\. | [^"\\] )* " /x;
our $RXstr = qr/ ( $RXname | $RXnum | $RXdqs ) /x;
our @context;
sub pushContext {
my ($ctxt) = @_;
unshift @context, $ctxt;
}
sub popContext {
my ($ctxt) = @_;
my $pop = shift @context;
($ctxt ne $pop) and
dieContext("Leaving context \"$ctxt\", found \"$pop\" instead.",
"\tBraces must be closed in the same file they open in.");
}
sub dieContext {
my $msg = join "\n\t", @_;
die "$msg\nContext: ", join(' in ', @context), "\n";
}
sub warnContext {
my $msg = join "\n\t", @_;
print STDERR "$msg\nContext: ", join(' in ', @context), "\n";
}
# 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
do double dynamic_cast else enum explicit export extern false float for
friend goto if inline int long mutable namespace new not not_eq operator or
or_eq private protected public register reinterpret_cast return short signed
sizeof static static_cast struct switch template this throw true try typedef
typeid typename union unsigned using virtual void volatile wchar_t while xor
xor_eq addpath alias breaktable choice device driver field function grecord
include info menu path record recordtype registrar variable);
sub is_reserved {
my $id = shift;
return exists $reserved{$id};
}
sub identifier {
my ($this, $id, $what) = @_;
confess "DBD::Base::identifier: $what undefined!"
unless defined $id;
$id =~ m/^$RXident$/ or dieContext("Illegal $what '$id'",
"Identifiers are used in C code so must start with a letter, followed",
"by letters, digits and/or underscore characters only.");
dieContext("Illegal $what '$id'",
"Identifier is a C++ reserved word.")
if is_reserved($id);
return $id;
}
# Output filtering
sub escapeCcomment {
($_) = @_;
s/\*\//**/g;
return $_;
}
sub escapeCstring {
($_) = @_;
# FIXME: How to do this?
return $_;
}
# Base methods for the DBD component objects
sub new {
my $class = shift;
my $this = {};
bless $this, $class;
return $this->init(@_);
}
sub init {
my ($this, $name, $what) = @_;
$this->{NAME} = $this->identifier($name, "$what name");
$this->{WHAT} = $what;
return $this;
}
sub name {
return shift->{NAME};
}
sub what {
return shift->{WHAT};
}
sub add_comment {
my $this = shift;
confess "add_comment() not supported by $this->{WHAT} ($this)\n",
"Context: ", join(' in ', @context), "\n";
}
sub add_pod {
my $this = shift;
warnContext "Warning: Pod text inside $this->{WHAT} will be ignored";
}
sub equals {
my ($a, $b) = @_;
return $a->{NAME} eq $b->{NAME}
&& $a->{WHAT} eq $b->{WHAT};
}
1;
modules/database/src/tools/DBD/Breaktable.pm
+59
View File
@@ -0,0 +1,59 @@
package DBD::Breaktable;
use DBD::Base;
@ISA = qw(DBD::Base);
use Carp;
sub init {
my ($this, $name) = @_;
$this->SUPER::init($name, "breakpoint table");
$this->{POINT_LIST} = [];
$this->{COMMENTS} = [];
$this->{POD} = [];
return $this;
}
sub add_point {
my ($this, $raw, $eng) = @_;
confess "DBD::Breaktable::add_point: Raw value undefined!"
unless defined $raw;
confess "DBD::Breaktable::add_point: Engineering value undefined!"
unless defined $eng;
push @{$this->{POINT_LIST}}, [$raw, $eng];
}
sub points {
return @{shift->{POINT_LIST}};
}
sub point {
my ($this, $idx) = @_;
return $this->{POINT_LIST}[$idx];
}
sub add_comment {
my $this = shift;
push @{$this->{COMMENTS}}, @_;
}
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)
&& join(',', map "$_->[0]:$_->[1]", @{$a->{POINT_LIST}})
eq join(',', map "$_->[0]:$_->[1]", @{$b->{POINT_LIST}});
}
1;
modules/database/src/tools/DBD/Device.pm
+51
View File
@@ -0,0 +1,51 @@
package DBD::Device;
use DBD::Base;
@ISA = qw(DBD::Base);
my %link_types = (
CONSTANT => qr/$RXnum/,
PV_LINK => qr/$RXname \s+ [.NPCAMS ]*/x,
JSON_LINK => qr/\{ .* \}/x,
VME_IO => qr/\# (?: \s* [CS] \s* $RXintx)* \s* (?: @ .*)?/x,
CAMAC_IO => qr/\# (?: \s* [BCNAF] \s* $RXintx)* \s* (?: @ .*)?/x,
RF_IO => qr/\# (?: \s* [RMDE] \s* $RXintx)*/x,
AB_IO => qr/\# (?: \s* [LACS] \s* $RXintx)* \s* (?: @ .*)?/x,
GPIB_IO => qr/\# (?: \s* [LA] \s* $RXintx)* \s* (?: @ .*)?/x,
BITBUS_IO => qr/\# (?: \s* [LNPS] \s* $RXuintx)* \s* (?: @ .*)?/x,
BBGPIB_IO => qr/\# (?: \s* [LBG] \s* $RXuintx)* \s* (?: @ .*)?/x,
VXI_IO => qr/\# (?: \s* [VCS] \s* $RXintx)* \s* (?: @ .*)?/x,
INST_IO => qr/@.*/
);
sub init {
my ($this, $link_type, $dset, $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)");
$this->{LINK_TYPE} = $link_type;
$this->{CHOICE} = $choice;
return $this;
}
sub link_type {
return shift->{LINK_TYPE};
}
sub choice {
return shift->{CHOICE};
}
sub legal_addr {
my ($this, $addr) = @_;
my $rx = $link_types{$this->{LINK_TYPE}};
return $addr =~ m/^ $rx $/x;
}
sub equals {
my ($a, $b) = @_;
return $a->SUPER::equals($b)
&& $a->{LINK_TYPE} eq $b->{LINK_TYPE}
&& $a->{CHOICE} eq $b->{CHOICE};
}
1;
modules/database/src/tools/DBD/Driver.pm
+9
View File
@@ -0,0 +1,9 @@
package DBD::Driver;
use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
return shift->SUPER::init(shift, "driver support (drvet)");
}
1;
modules/database/src/tools/DBD/Function.pm
+9
View File
@@ -0,0 +1,9 @@
package DBD::Function;
use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
return shift->SUPER::init(shift, "function");
}
1;
modules/database/src/tools/DBD/Link.pm
+22
View File
@@ -0,0 +1,22 @@
package DBD::Link;
use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
my ($this, $name, $jlif) = @_;
$this->SUPER::init($jlif, "link support (jlif)");
$this->{KEY} = $name;
return $this;
}
sub key {
return shift->{KEY};
}
sub equals {
my ($a, $b) = @_;
return $a->SUPER::equals($b)
&& $a->{KEY} eq $b->{KEY};
}
1;
modules/database/src/tools/DBD/Menu.pm
+84
View File
@@ -0,0 +1,84 @@
package DBD::Menu;
use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
my ($this, $name) = @_;
$this->SUPER::init($name, "menu");
$this->{CHOICE_LIST} = [];
$this->{CHOICE_INDEX} = {};
$this->{COMMENTS} = [];
return $this;
}
sub add_choice {
my ($this, $name, $value) = @_;
$name = $this->identifier($name, "Choice name");
foreach $pair ($this->choices) {
dieContext("Duplicate menu choice name '$name'")
if ($pair->[0] eq $name);
dieContext("Duplicate menu choice string '$value'")
if ($pair->[1] eq $value);
}
push @{$this->{CHOICE_LIST}}, [$name, $value];
$this->{CHOICE_INDEX}->{$value} = $name;
}
sub choices {
return @{shift->{CHOICE_LIST}};
}
sub choice {
my ($this, $idx) = @_;
return $this->{CHOICE_LIST}[$idx];
}
sub legal_choice {
my ($this, $value) = @_;
return exists $this->{CHOICE_INDEX}->{$value};
}
sub add_comment {
my $this = shift;
push @{$this->{COMMENTS}}, @_;
}
sub comments {
return @{shift->{COMMENTS}};
}
sub equals {
my ($a, $b) = @_;
return $a->SUPER::equals($b)
&& join(',', map "$_->[0]:$_->[1]", @{$a->{CHOICE_LIST}})
eq join(',', map "$_->[0]:$_->[1]", @{$b->{CHOICE_LIST}});
}
sub toDeclaration {
my $this = shift;
my $name = $this->name;
my @choices = map {
sprintf " %-31s /* %s */", @{$_}[0], escapeCcomment(@{$_}[1]);
} $this->choices;
my $num = scalar @choices;
return "typedef enum {\n" .
join(",\n", @choices) .
"\n} $name;\n" .
"#define ${name}_NUM_CHOICES $num\n\n";
}
sub toDefinition {
my $this = shift;
my $name = $this->name;
my @strings = map {
"\t\"" . escapeCstring(@{$_}[1]) . "\""
} $this->choices;
return "static const char * const ${name}ChoiceStrings[] = {\n" .
join(",\n", @strings) . "\n};\n" .
"const dbMenu ${name}MenuMetaData = {\n" .
"\t\"" . escapeCstring($name) . "\",\n" .
"\t${name}_NUM_CHOICES,\n" .
"\t${name}ChoiceStrings\n};\n\n";
}
1;
modules/database/src/tools/DBD/Output.pm
+138
View File
@@ -0,0 +1,138 @@
package DBD::Output;
use strict;
use warnings;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(&OutputDBD &OutputDB);
use DBD;
use DBD::Base;
use DBD::Breaktable;
use DBD::Device;
use DBD::Driver;
use DBD::Link;
use DBD::Menu;
use DBD::Recordtype;
use DBD::Recfield;
use DBD::Record;
use DBD::Registrar;
use DBD::Function;
use DBD::Variable;
sub OutputDBD {
my ($out, $dbd) = @_;
OutputMenus($out, $dbd->menus);
OutputRecordtypes($out, $dbd->recordtypes);
OutputDrivers($out, $dbd->drivers);
OutputLinks($out, $dbd->links);
OutputRegistrars($out, $dbd->registrars);
OutputFunctions($out, $dbd->functions);
OutputVariables($out, $dbd->variables);
OutputBreaktables($out, $dbd->breaktables);
}
sub OutputDB {
my ($out, $dbd) = @_;
OutputRecords($out, $dbd->records);
}
sub OutputMenus {
my ($out, $menus) = @_;
while (my ($name, $menu) = each %{$menus}) {
printf $out "menu(%s) {\n", $name;
printf $out " choice(%s, \"%s\")\n", @{$_}
foreach $menu->choices;
print $out "}\n";
}
}
sub OutputRecordtypes {
my ($out, $recordtypes) = @_;
while (my ($name, $recordtype) = each %{$recordtypes}) {
printf $out "recordtype(%s) {\n", $name;
print $out " %$_\n"
foreach $recordtype->cdefs;
foreach my $field ($recordtype->fields) {
printf $out " field(%s, %s) {\n",
$field->name, $field->dbf_type;
while (my ($attr, $val) = each %{$field->attributes}) {
$val = "\"$val\""
if $val !~ m/^$RXname$/x
|| $attr eq 'prompt'
|| $attr eq 'initial';
printf $out " %s(%s)\n", $attr, $val;
}
print $out " }\n";
}
printf $out "}\n";
printf $out "device(%s, %s, %s, \"%s\")\n",
$name, $_->link_type, $_->name, $_->choice
foreach $recordtype->devices;
}
}
sub OutputDrivers {
my ($out, $drivers) = @_;
printf $out "driver(%s)\n", $_
foreach keys %{$drivers};
}
sub OutputLinks {
my ($out, $links) = @_;
while (my ($name, $link) = each %{$links}) {
printf $out "link(%s, %s)\n", $link->key, $name;
}
}
sub OutputRegistrars {
my ($out, $registrars) = @_;
printf $out "registrar(%s)\n", $_
foreach keys %{$registrars};
}
sub OutputFunctions {
my ($out, $functions) = @_;
printf $out "function(%s)\n", $_
foreach keys %{$functions};
}
sub OutputVariables {
my ($out, $variables) = @_;
while (my ($name, $variable) = each %{$variables}) {
printf $out "variable(%s, %s)\n", $name, $variable->var_type;
}
}
sub OutputBreaktables {
my ($out, $breaktables) = @_;
while (my ($name, $breaktable) = each %{$breaktables}) {
printf $out "breaktable(\"%s\") {\n", $name;
printf $out " %s, %s\n", @{$_}
foreach $breaktable->points;
print $out "}\n";
}
}
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;
modules/database/src/tools/DBD/Parser.pm
+318
View File
@@ -0,0 +1,318 @@
package DBD::Parser;
use strict;
use warnings;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(&ParseDBD);
use DBD;
use DBD::Base;
use DBD::Breaktable;
use DBD::Device;
use DBD::Driver;
use DBD::Link;
use DBD::Menu;
use DBD::Recordtype;
use DBD::Recfield;
use DBD::Record;
use DBD::Registrar;
use DBD::Function;
use DBD::Variable;
our $debug=0;
sub ParseDBD {
(my $dbd, $_) = @_;
while (1) {
parseCommon($dbd);
if (m/\G menu \s* \( \s* $RXstr \s* \) \s* \{/xgc) {
print "Menu: $1\n" if $debug;
my ($menu_name) = unquote($1);
parse_menu($dbd, $menu_name);
}
elsif (m/\G driver \s* \( \s* $RXstr \s* \)/xgc) {
print "Driver: $1\n" if $debug;
my ($driver_name) = unquote($1);
$dbd->add(DBD::Driver->new($driver_name));
}
elsif (m/\G link \s* \( \s* $RXstr \s*, \s* $RXstr \s* \)/xgc) {
print "Link $1, $2\n" if $debug;
my ($key, $lset) = unquote($1, $2);
$dbd->add(DBD::Link->new($key, $lset));
}
elsif (m/\G registrar \s* \( \s* $RXstr \s* \)/xgc) {
print "Registrar: $1\n" if $debug;
my ($registrar_name) = unquote($1);
$dbd->add(DBD::Registrar->new($registrar_name));
}
elsif (m/\G function \s* \( \s* $RXstr \s* \)/xgc) {
print "Function: $1\n" if $debug;
my ($function_name) = unquote($1);
$dbd->add(DBD::Function->new($function_name));
}
elsif (m/\G breaktable \s* \( \s* $RXstr \s* \) \s* \{/xgc) {
print "Breaktable: $1\n" if $debug;
my ($breaktable_name) = unquote($1);
parse_breaktable($dbd, $breaktable_name);
}
elsif (m/\G recordtype \s* \( \s* $RXstr \s* \) \s* \{/xgc) {
print "Recordtype: $1\n" if $debug;
my ($recordtype_name) = unquote($1);
parse_recordtype($dbd, $recordtype_name);
}
elsif (m/\G g?record \s* \( \s* $RXstr \s*, \s* $RXstr \s* \) \s* \{/xgc) {
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* \)/xgc) {
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* \)/xgc) {
print "Variable: $1\n" if $debug;
my ($variable_name) = unquote($1);
$dbd->add(DBD::Variable->new($variable_name));
}
elsif (m/\G variable \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/xgc) {
print "Variable: $1, $2\n" if $debug;
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* \)/xgc) {
print "Device: $1, $2, $3, $4\n" if $debug;
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($record_type);
warn "Device using undefined record type '$record_type', place-holder created\n";
$dbd->add($rtyp);
}
$rtyp->add_device(DBD::Device->new($link_type, $dset, $choice));
} else {
last unless m/\G (.*) $/moxgc;
dieContext("Syntax error in '$1'");
}
}
}
sub parseCommon {
my ($obj) = @_;
while (1) {
# Skip leading whitespace
m/\G \s* /xgc;
# Extract POD
if (m/\G ( = [a-zA-Z] )/xgc) {
# The above regex was split from the one below for performance.
# Using m/\G ( = [a-zA-Z] .* ) \n/ is slow in Perl 5.20 and later.
my $directive = $1;
m/\G ( .* ) \n/xgc;
$directive .= $1;
$obj->add_pod($directive, parsePod());
}
elsif (m/\G \# /xgc) {
if (m/\G \# ! BEGIN \{ ( [^}]* ) \} ! \# \# \n/xgc) {
print "File-Begin: $1\n" if $debug;
pushContext("file '$1'");
}
elsif (m/\G \# ! END \{ ( [^}]* ) \} ! \# \# \n?/xgc) {
print "File-End: $1\n" if $debug;
popContext("file '$1'");
}
else {
m/\G (.*) \n/xgc;
$obj->add_comment($1);
print "Comment: $1\n" if $debug;
}
} else {
return;
}
}
}
sub unquote {
return map { m/^ ("?) (.*) \1 $/x; $2 } @_;
}
sub parsePod {
pushContext("Pod markup");
my @pod;
while (1) {
if (m/\G ( =cut .* ) \n?/xgc) {
popContext("Pod markup");
return @pod;
}
elsif (m/\G ( .* ) $/xgc) {
dieContext("Unexpected end of input file, Pod block not closed");
}
elsif (m/\G ( .* ) \n/xgc) {
push @pod, $1
}
}
}
sub parse_menu {
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* \)/xgc) {
print " Menu-Choice: $1, $2\n" if $debug;
my ($choice_name, $value) = unquote($1, $2);
$menu->add_choice($choice_name, $value);
}
elsif (m/\G \}/xgc) {
print " Menu-End:\n" if $debug;
$dbd->add($menu);
popContext("menu($menu_name)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
sub parse_breaktable {
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* \)/xgc) {
print " Breaktable-Point: $1, $2\n" if $debug;
my ($raw, $eng) = unquote($1, $2);
$bt->add_point($raw, $eng);
}
elsif (m/\G $RXstr \s* (?: , \s*)? $RXstr (?: \s* ,)?/xgc) {
print " Breaktable-Data: $1, $2\n" if $debug;
my ($raw, $eng) = unquote($1, $2);
$bt->add_point($raw, $eng);
}
elsif (m/\G \}/xgc) {
print " Breaktable-End:\n" if $debug;
$dbd->add($bt);
popContext("breaktable($breaktable_name)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
sub parse_recordtype {
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* \{/xgc) {
print " Recordtype-Field: $1, $2\n" if $debug;
my ($field_name, $field_type) = unquote($1, $2);
parse_field($rtyp, $field_name, $field_type);
}
elsif (m/\G % (.*) \n/xgc) {
print " Recordtype-Cdef: $1\n" if $debug;
$rtyp->add_cdef($1);
}
elsif (m/\G \}/xgc) {
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);
my $rec = $dbd->record($record_name);
if (defined $rec) {
my $otyp = $rec->recordtype;
my $otyp_name = $otyp->name;
$rtyp = $otyp if $record_type eq '*';
dieContext("A(n) $otyp_name record '$record_name' already exists")
unless $otyp == $rtyp;
} else {
dieContext("No record exists named '$record_name'")
if $record_type eq '*';
dieContext("No recordtype exists named '$record_type'")
unless defined $rtyp;
$rec = DBD::Record->new($rtyp, $record_name);
}
while (1) {
parseCommon($rec);
if (m/\G field \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/xgc) {
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* \)/xgc) {
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* \)/xgc) {
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 \}/xgc) {
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'");
}
}
}
sub parse_field {
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* \)/xgc) {
print " Field-Attribute: $1, $2\n" if $debug;
my ($attr, $value) = unquote($1, $2);
$fld->add_attribute($attr, $value);
}
elsif (m/\G \}/xgc) {
print " Field-End:\n" if $debug;
$rtyp->add_field($fld);
popContext("field($field_name, $field_type)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
1;
modules/database/src/tools/DBD/Recfield.pm
+525
View File
@@ -0,0 +1,525 @@
package DBD::Recfield;
use DBD::Base;
@ISA = qw(DBD::Base);
# The hash value is a regexp that matches all legal values of this field
# NB: The regexps are not currently used, and are wrong for some types.
our %field_types = (
DBF_STRING => qr/.{0,40}/,
DBF_CHAR => $RXintx,
DBF_UCHAR => $RXuintx,
DBF_SHORT => $RXintx,
DBF_USHORT => $RXuintx,
DBF_LONG => $RXintx,
DBF_ULONG => $RXuintx,
DBF_INT64 => $RXintx,
DBF_UINT64 => $RXuintx,
DBF_FLOAT => $RXnum,
DBF_DOUBLE => $RXnum,
DBF_ENUM => qr/.*/,
DBF_MENU => qr/.*/,
DBF_DEVICE => qr/.*/,
DBF_INLINK => qr/.*/,
DBF_OUTLINK => qr/.*/,
DBF_FWDLINK => qr/.*/,
DBF_NOACCESS => qr//
);
# The hash value is a regexp that matches all legal values of this attribute
our %field_attrs = (
asl => qr/^ASL[01]$/,
initial => qr/^.*$/,
promptgroup => qr/^.*$/,
prompt => qr/^.*$/,
special => qr/^(?:SPC_\w+|\d{3,})$/,
pp => qr/^(?:TRUE|FALSE)$/,
interest => qr/^\d+$/,
base => qr/^(?:DECIMAL|HEX)$/,
size => qr/^\d+$/,
extra => qr/^.*$/,
menu => qr/^$RXident$/,
prop => qr/^(?:YES|NO)$/
);
# Convert old promptgroups into new-style
my %promptgroupMap = (
GUI_COMMON => '10 - Common',
GUI_ALARMS => '70 - Alarm',
GUI_BITS1 => '41 - Bits (1)',
GUI_BITS2 => '42 - Bits (2)',
GUI_CALC => '30 - Action',
GUI_CLOCK => '30 - Action',
GUI_COMPRESS => '30 - Action',
GUI_CONVERT => '60 - Convert',
GUI_DISPLAY => '80 - Display',
GUI_HIST => '30 - Action',
GUI_INPUTS => '40 - Input',
GUI_LINKS => '40 - Link',
GUI_MBB => '30 - Action',
GUI_MOTOR => '30 - Action',
GUI_OUTPUT => '50 - Output',
GUI_PID => '30 - Action',
GUI_PULSE => '30 - Action',
GUI_SELECT => '40 - Input',
GUI_SEQ1 => '51 - Output (1)',
GUI_SEQ2 => '52 - Output (2)',
GUI_SEQ3 => '53 - Output (3)',
GUI_SUB => '30 - Action',
GUI_TIMER => '30 - Action',
GUI_WAVE => '30 - Action',
GUI_SCAN => '20 - Scan',
);
sub new {
my ($class, $name, $type) = @_;
dieContext("Illegal field type '$type', valid field types are:",
sort keys %field_types) unless exists $field_types{$type};
my $this = {};
bless $this, "${class}::${type}";
return $this->init($name, $type);
}
sub init {
my ($this, $name, $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};
$this->{DBF_TYPE} = $type;
$this->{ATTR_INDEX} = {};
$this->{COMMENTS} = [];
return $this;
}
sub dbf_type {
return shift->{DBF_TYPE};
}
sub set_number {
my ($this, $number) = @_;
$this->{NUMBER} = $number;
}
sub number {
return shift->{NUMBER};
}
sub add_attribute {
my ($this, $attr, $value) = @_;
$value = $promptgroupMap{$value}
if $attr eq 'promptgroup' && exists $promptgroupMap{$value};
my $match = $field_attrs{$attr};
if (defined $match) {
dieContext("Bad value '$value' for field attribute '$attr'")
unless $value =~ m/$match/;
}
else {
warnContext("Unknown field attribute '$attr' with value '$value'; " .
"known attributes are:",
join(", ", sort keys %field_attrs));
}
$this->{ATTR_INDEX}->{$attr} = $value;
}
sub attributes {
return shift->{ATTR_INDEX};
}
sub attribute {
my ($this, $attr) = @_;
return $this->attributes->{$attr};
}
sub equals {
dieContext("Record field objects are not comparable");
}
sub check_valid {
my ($this) = @_;
my $name = $this->name;
my $default = $this->attribute("initial");
dieContext("Default value '$default' is invalid for field '$name'")
if (defined($default) and !$this->legal_value($default));
}
sub add_comment {
my $this = shift;
push @{$this->{COMMENTS}}, @_;
}
sub comments {
return @{shift->{COMMENTS}};
}
# The C structure member name is usually the field name converted to
# lower-case. However if that is a reserved word, use the original.
sub C_name {
my ($this) = @_;
my $name = lc $this->name;
$name = $this->name
if is_reserved($name);
return $name;
}
sub toDeclaration {
my ($this, $ctype) = @_;
my $name = $this->C_name;
my $result = sprintf " %-19s %-12s", $ctype, "$name;";
my $prompt = $this->attribute('prompt');
$result .= "/* $prompt */" if defined $prompt;
return $result;
}
################################################################################
package DBD::Recfield::DBF_STRING;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
return (length $value < $this->attribute('size'));
# NB - we use '<' to allow space for the terminating nil byte
}
sub check_valid {
my ($this) = @_;
dieContext("Size missing for DBF_STRING field '$name'")
unless exists $this->attributes->{'size'};
$this->SUPER::check_valid;
}
sub toDeclaration {
my ($this) = @_;
my $name = lc $this->name;
my $size = $this->attribute('size');
my $result = sprintf " %-19s %-12s", 'char', "${name}[${size}];";
my $prompt = $this->attribute('prompt');
$result .= "/* $prompt */" if defined $prompt;
return $result;
}
################################################################################
package DBD::Recfield::DBF_CHAR;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
$value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
return ($value =~ m/^ $RXint $/x and
$value >= -128 and
$value <= 127);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsInt8");
}
################################################################################
package DBD::Recfield::DBF_UCHAR;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
$value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
return ($value =~ m/^ $RXuint $/x and
$value >= 0 and
$value <= 255);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsUInt8");
}
################################################################################
package DBD::Recfield::DBF_SHORT;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
$value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
return ($value =~ m/^ $RXint $/x and
$value >= -32768 and
$value <= 32767);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsInt16");
}
################################################################################
package DBD::Recfield::DBF_USHORT;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
$value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
return ($value =~ m/^ $RXuint $/x and
$value >= 0 and
$value <= 65535);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsUInt16");
}
################################################################################
package DBD::Recfield::DBF_LONG;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
$value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
return ($value =~ m/^ $RXint $/x);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsInt32");
}
################################################################################
package DBD::Recfield::DBF_ULONG;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
$value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
return ($value =~ m/^ $RXuint $/x and
$value >= 0);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsUInt32");
}
################################################################################
package DBD::Recfield::DBF_INT64;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
$value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
return ($value =~ m/^ $RXint $/x);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsInt64");
}
################################################################################
package DBD::Recfield::DBF_UINT64;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
$value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
return ($value =~ m/^ $RXuint $/x and
$value >= 0);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsUInt64");
}
################################################################################
package DBD::Recfield::DBF_FLOAT;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
return ($value =~ m/^ $RXnum $/x);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsFloat32");
}
################################################################################
package DBD::Recfield::DBF_DOUBLE;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
return ($value =~ m/^ $RXnum $/x);
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsFloat64");
}
################################################################################
package DBD::Recfield::DBF_ENUM;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
return 1;
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsEnum16");
}
################################################################################
package DBD::Recfield::DBF_MENU;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
# FIXME: If we know the menu name and the menu exists, check further
return 1;
}
sub check_valid {
my ($this) = @_;
dieContext("Menu name missing for DBF_MENU field '$name'")
unless defined($this->attribute("menu"));
$this->SUPER::check_valid;
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsEnum16");
}
################################################################################
package DBD::Recfield::DBF_DEVICE;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
return 1;
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsEnum16");
}
################################################################################
package DBD::Recfield::DBF_INLINK;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
return 1;
}
sub toDeclaration {
return shift->SUPER::toDeclaration("DBLINK");
}
################################################################################
package DBD::Recfield::DBF_OUTLINK;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
return 1;
}
sub toDeclaration {
return shift->SUPER::toDeclaration("DBLINK");
}
################################################################################
package DBD::Recfield::DBF_FWDLINK;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
return 1;
}
sub toDeclaration {
return shift->SUPER::toDeclaration("DBLINK");
}
################################################################################
package DBD::Recfield::DBF_NOACCESS;
use DBD::Base;
@ISA = qw(DBD::Recfield);
sub legal_value {
my ($this, $value) = @_;
return ($value eq '');
}
sub check_valid {
my ($this) = @_;
dieContext("Type information missing for DBF_NOACCESS field '$name'")
unless defined($this->attribute("extra"));
$this->SUPER::check_valid;
}
sub toDeclaration {
my ($this) = @_;
my $extra = $this->attribute('extra');
my $result = sprintf " %-31s ", "$extra;";
my $prompt = $this->attribute('prompt');
$result .= "/* $prompt */" if defined $prompt;
return $result;
}
1;
modules/database/src/tools/DBD/Record.pm
+123
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$/) {
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;
modules/database/src/tools/DBD/Recordtype.pm
+124
View File
@@ -0,0 +1,124 @@
package DBD::Recordtype;
use DBD::Base;
@ISA = qw(DBD::Base);
use Carp;
sub init {
my ($this, $name) = @_;
$this->SUPER::init($name, "record type");
$this->{FIELD_LIST} = [];
$this->{FIELD_INDEX} = {};
$this->{DEVICE_LIST} = [];
$this->{DEVICE_INDEX} = {};
$this->{CDEFS} = [];
$this->{COMMENTS} = [];
$this->{POD} = [];
return $this;
}
sub add_field {
my ($this, $field) = @_;
confess "DBD::Recordtype::add_field: Not a DBD::Recfield"
unless $field->isa('DBD::Recfield');
my $field_name = $field->name;
dieContext("Duplicate field name '$field_name'")
if exists $this->{FIELD_INDEX}->{$field_name};
$field->check_valid;
$field->set_number(scalar @{$this->{FIELD_LIST}});
push @{$this->{FIELD_LIST}}, $field;
$this->{FIELD_INDEX}->{$field_name} = $field;
}
sub fields {
return @{shift->{FIELD_LIST}};
}
sub field_names { # In their original order...
return map {$_->name} @{shift->{FIELD_LIST}};
}
sub field {
my ($this, $field_name) = @_;
return $this->{FIELD_INDEX}->{$field_name};
}
sub add_device {
my ($this, $device) = @_;
confess "DBD::Recordtype::add_device: Not a DBD::Device"
unless $device->isa('DBD::Device');
my $choice = $device->choice;
if (exists $this->{DEVICE_INDEX}->{$choice}) {
return if $device->equals($this->{DEVICE_INDEX}->{$choice});
my @warning = ("Two $this->{NAME} device supports '$choice' conflict");
my $old = $this->{DEVICE_INDEX}->{$choice};
push @warning, "Link types differ"
if $old->link_type ne $device->link_type;
push @warning, "DSETs differ"
if $old->name ne $device->name;
dieContext(@warning);
}
push @{$this->{DEVICE_LIST}}, $device;
$this->{DEVICE_INDEX}->{$choice} = $device;
}
sub devices {
return @{shift->{DEVICE_LIST}};
}
sub device {
my ($this, $choice) = @_;
return $this->{DEVICE_INDEX}->{$choice};
}
sub add_comment {
my ($this, $comment) = @_;
push @{$this->{COMMENTS}}, $comment;
}
sub comments {
return @{shift->{COMMENTS}};
}
sub add_cdef {
my ($this, $cdef) = @_;
push @{$this->{CDEFS}}, $cdef;
}
sub cdefs {
return @{shift->{CDEFS}};
}
sub toCdefs {
return join("\n", shift->cdefs) . "\n\n";
}
sub add_pod {
my $this = shift;
push @{$this->{POD}}, @_;
}
sub pod {
return @{shift->{POD}};
}
sub equals {
my ($new, $known) = @_;
return 0 if ! $known->fields;
return 1 if ! $new->fields;
dieContext("Duplicate definition of record type '$known->{NAME}'");
}
sub toDeclaration {
my $this = shift;
my @fields = map {
$_->toDeclaration
} $this->fields;
my $name = $this->name;
$name .= "Record" unless $name eq "dbCommon";
return "typedef struct $name {\n" .
join("\n", @fields) .
"\n} $name;\n\n";
}
1;
modules/database/src/tools/DBD/Registrar.pm
+9
View File
@@ -0,0 +1,9 @@
package DBD::Registrar;
use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
return shift->SUPER::init(shift, "registrar function");
}
1;
modules/database/src/tools/DBD/Variable.pm
+38
View File
@@ -0,0 +1,38 @@
package DBD::Variable;
use DBD::Base;
@ISA = qw(DBD::Base);
my %valid_types = (
# C type name => corresponding iocshArg type identifier
int => 'iocshArgInt',
double => 'iocshArgDouble'
);
sub init {
my ($this, $name, $type) = @_;
$type = "int" unless defined $type;
exists $valid_types{$type} or
dieContext("Unknown variable type '$type', valid types are:",
sort keys %valid_types);
$this->SUPER::init($name, "variable");
$this->{VAR_TYPE} = $type;
return $this;
}
sub var_type {
my $this = shift;
return $this->{VAR_TYPE};
}
sub iocshArg_type {
my $this = shift;
return $valid_types{$this->{VAR_TYPE}};
}
sub equals {
my ($a, $b) = @_;
return $a->SUPER::equals($b)
&& $a->{VAR_TYPE} eq $b->{VAR_TYPE};
}
1;
modules/database/src/tools/Makefile
+38
View File
@@ -0,0 +1,38 @@
#*************************************************************************
# Copyright (c) 2012 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.
#*************************************************************************
TOP=../..
include $(TOP)/configure/CONFIG
PERL_MODULES += DBD.pm
PERL_MODULES += DBD/Base.pm
PERL_MODULES += DBD/Breaktable.pm
PERL_MODULES += DBD/Device.pm
PERL_MODULES += DBD/Driver.pm
PERL_MODULES += DBD/Link.pm
PERL_MODULES += DBD/Function.pm
PERL_MODULES += DBD/Menu.pm
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
PERL_SCRIPTS += databaseModuleDirs.pm
PERL_SCRIPTS += makeIncludeDbd.pl
PERL_SCRIPTS += dbdToMenuH.pl
PERL_SCRIPTS += dbdToRecordtypeH.pl
PERL_SCRIPTS += dbdExpand.pl
PERL_SCRIPTS += dbExpand.pl
PERL_SCRIPTS += dbdToHtml.pl
PERL_SCRIPTS += registerRecordDeviceDriver.pl
include $(TOP)/configure/RULES
modules/database/src/tools/dbExpand.pl
+90
View File
@@ -0,0 +1,90 @@
#!/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, "$Bin/../../lib/perl");
use databaseModuleDirs;
no lib $Bin;
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;
modules/database/src/tools/dbdExpand.pl
+86
View File
@@ -0,0 +1,86 @@
#!/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.
#*************************************************************************
use strict;
use FindBin qw($Bin);
use lib ($Bin, "$Bin/../../lib/perl");
use databaseModuleDirs;
no lib $Bin;
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);
getopts('DI@S@o:') or
die "Usage: dbdExpand [-D] [-I dir] [-S macro=val] [-o out.dbd] in.dbd ...";
my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
my $macros = EPICS::macLib->new(@opt_S);
my $dbd = DBD->new();
$macros->suppressWarning(1);
# 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 "dbdExpand.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 "dbdExpand.pl: $@";
warn " while reading '$file' to create '$opt_o$dot_d'\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 "dbdExpand.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;
}
OutputDBD($out, $dbd);
if ($opt_o) {
close $out or die "Closing $opt_o failed: $!\n";
}
exit 0;
modules/database/src/tools/dbdReport.pl
+67
View File
@@ -0,0 +1,67 @@
#!/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.
#*************************************************************************
use FindBin qw($Bin);
use lib ($Bin, "$Bin/../../lib/perl");
use databaseModuleDirs;
no lib $Bin;
use DBD;
use DBD::Parser;
use EPICS::Getopts;
use EPICS::macLib;
use EPICS::Readfile;
use Text::Wrap;
#$EPICS::Readfile::debug = 1;
#$DBD::Parser::debug = 1;
getopts('I@S@') or die usage();
sub usage() {
"Usage: dbdReport [-I dir:dir2] [-S macro=val,...] file.dbd ...";
}
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)) while @ARGV;
$Text::Wrap::columns = 75;
my @menus = sort keys %{$dbd->menus};
print wrap("Menus:\t", "\t", join(', ', @menus)), "\n"
if @menus;
my @drivers = sort keys %{$dbd->drivers};
print wrap("Drivers: ", "\t", join(', ', @drivers)), "\n"
if @drivers;
my @variables = sort keys %{$dbd->variables};
print wrap("Variables: ", "\t", join(', ', @variables)), "\n"
if @variables;
my @registrars = sort keys %{$dbd->registrars};
print wrap("Registrars: ", "\t", join(', ', @registrars)), "\n"
if @registrars;
my @breaktables = sort keys %{$dbd->breaktables};
print wrap("Breaktables: ", "\t", join(', ', @breaktables)), "\n"
if @breaktables;
my %recordtypes = %{$dbd->recordtypes};
if (%recordtypes) {
@rtypes = sort keys %recordtypes;
print wrap("Recordtypes: ", "\t", join(', ', @rtypes)), "\n";
foreach my $rtyp (@rtypes) {
my @devices = $recordtypes{$rtyp}->devices;
print wrap("Devices($rtyp): ", "\t",
join(', ', map {$_->choice} @devices)), "\n"
if @devices;
}
}
my @records = sort keys %{$dbd->records};
print wrap("Records: ", "\t", join(', ', @records)), "\n"
if @records;
modules/database/src/tools/dbdToHtml.pl
+247
View File
@@ -0,0 +1,247 @@
#!/usr/bin/env perl
#*************************************************************************
# Copyright (c) 2012 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.
#*************************************************************************
use strict;
use FindBin qw($Bin);
use lib ($Bin, "$Bin/../../lib/perl");
use databaseModuleDirs;
no lib $Bin;
use DBD;
use DBD::Parser;
use EPICS::Getopts;
use EPICS::macLib;
use EPICS::Readfile;
BEGIN {
$::XHTML = eval "require Pod::Simple::XHTML; 1";
$::ENTITIES = eval "require HTML::Entities; 1";
if (!$::XHTML) {
require Pod::Simple::HTML;
}
if (!$::ENTITIES) {
my %entities = (
q{>} => 'gt',
q{<} => 'lt',
q{'} => '#39',
q{"} => 'quot',
q{&} => 'amp',
);
sub encode_entities {
my $str = shift;
my $ents = join '', keys %entities;
$str =~ s/([ $ents ])/'&' . ($entities{$1} || sprintf '#x%X', ord $1) . ';'/xge;
return $str;
}
}
}
my $tool = 'dbdToHtml';
use vars qw($opt_D @opt_I $opt_o);
getopts('DI@o:') or
die "Usage: $tool [-D] [-I dir] [-o file.html] file.dbd.pod\n";
my $dbd = DBD->new();
my $infile = shift @ARGV;
$infile =~ m/\.dbd.pod$/ or
die "$tool: Input file '$infile' must have '.dbd.pod' extension\n";
ParseDBD($dbd, Readfile($infile, 0, \@opt_I));
if (!$opt_o) {
($opt_o = $infile) =~ s/\.dbd\.pod$/.html/;
$opt_o =~ s/^.*\///;
$opt_o =~ s/dbCommonRecord/dbCommon/;
}
if ($opt_D) { # Output dependencies only
my %filecount;
my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
print "$opt_o: ", join(" \\\n ", @uniqfiles), "\n\n";
print map { "$_:\n" } @uniqfiles;
exit 0;
}
(my $title = $opt_o) =~ s/\.html$//;
open my $out, '>', $opt_o or
die "Can't create $opt_o: $!\n";
# Parse the Pod text from the root DBD object
my $pod = join "\n", '=for html <div class="pod">', '',
map {
# Handle a 'recordtype' Pod directive
if (m/^ =recordtype \s+ (\w+) /x) {
my $rn = $1;
my $rtyp = $dbd->recordtype($rn);
die "Unknown recordtype '$rn' in $infile POD directive\n"
unless $rtyp;
rtypeToPod($rtyp, $dbd);
}
# Handle a 'menu' Pod directive
elsif (m/^ =menu \s+ (\w+) /x) {
my $mn = $1;
my $menu = $dbd->menu($mn);
die "Unknown menu '$mn' in $infile POD directive\n"
unless $menu;
menuToPod($menu);
}
elsif (m/^ =title \s+ (.*)/x) {
$title = $1;
"=head1 $title";
}
else {
$_;
}
} $dbd->pod,
'=for html </div>', '';
my $podHtml;
if ($::XHTML) {
$podHtml = Pod::Simple::XHTML->new();
$podHtml->html_doctype(<< '__END_DOCTYPE');
<?xml version='1.0' encoding='iso-8859-1'?>
<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.0 Transitional//EN'
'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'>
__END_DOCTYPE
$podHtml->html_header_tags($podHtml->html_header_tags .
"\n<link rel='stylesheet' href='style.css' type='text/css'>");
} else { # Fall back to HTML
$podHtml = Pod::Simple::HTML->new();
$podHtml->html_css('style.css');
}
$podHtml->force_title(encode_entities($title));
$podHtml->perldoc_url_prefix('');
$podHtml->perldoc_url_postfix('.html');
$podHtml->output_fh($out);
$podHtml->parse_string_document($pod);
close $out;
sub menuToPod {
my ($menu) = @_;
my $index = 0;
return '=begin html', '', '<blockquote><table border="1"><tr>',
'<th>Index</th><th>Identifier</th><th>Choice String</th></tr>',
map({choiceTableRow($_, $index++)} $menu->choices),
'</table></blockquote>', '', '=end html';
}
sub choiceTableRow {
my ($ch, $index) = @_;
my ($id, $name) = @{$ch};
return '<tr>',
"<td class='cell DBD_Menu index'>$index</td>",
"<td class='cell DBD_Menu identifier'>$id</td>",
"<td class='cell DBD_Menu choice'>$name</td>",
'</tr>';
}
sub rtypeToPod {
my ($rtyp, $dbd) = @_;
return map {
# Handle a 'fields' Pod directive
if (m/^ =fields \s+ (\w+ (?:\s* , \s* \w+ )* )/x) {
my @names = split /\s*,\s*/, $1;
# Look up the named fields
my @fields = map {
my $field = $rtyp->field($_);
die "Unknown field name '$_' in $infile POD\n"
unless $field;
$field;
} @names;
# Generate Pod for the table
'=begin html', '', '<blockquote><table border="1"><tr>',
'<th>Field</th><th>Summary</th><th>Type</th><th>DCT</th>',
'<th>Default</th><th>Read</th><th>Write</th><th>CA PP</th>',
'</tr>',
map({fieldTableRow($_, $dbd)} @fields),
'</table></blockquote>', '', '=end html';
}
# Handle a 'menu' Pod directive
elsif (m/^ =menu \s+ (\w+) /x) {
my $mn = $1;
my $menu = $dbd->menu($mn);
die "Unknown menu '$mn' in $infile POD directive\n"
unless $menu;
menuToPod($menu);
}
else {
# Raw text line
$_;
}
} $rtyp->pod;
}
sub fieldTableRow {
my ($fld, $dbd) = @_;
my $html = '<tr><td class="cell">';
$html .= $fld->name;
$html .= '</td><td class="cell">';
$html .= $fld->attribute('prompt');
$html .= '</td><td class="cell">';
my $type = $fld->public_type;
$html .= $type;
$html .= ' [' . $fld->attribute('size') . ']'
if $type eq 'STRING';
if ($type eq 'MENU') {
my $mn = $fld->attribute('menu');
my $menu = $dbd->menu($mn);
my $url = $menu ? "#Menu_$mn" : "${mn}.html";
$html .= " (<a href='$url'>$mn</a>)";
}
$html .= '</td><td class="cell">';
$html .= $fld->attribute('promptgroup') ? 'Yes' : 'No';
$html .= '</td><td class="cell">';
$html .= $fld->attribute('initial') || '&nbsp;';
$html .= '</td><td class="cell">';
$html .= $fld->readable;
$html .= '</td><td class="cell">';
$html .= $fld->writable;
$html .= '</td><td class="cell">';
$html .= $fld->attribute('pp') eq 'TRUE' ? 'Yes' : 'No';
$html .= "</td></tr>\n";
return $html;
}
# Native type presented to dbAccess users
sub DBD::Recfield::public_type {
my $fld = shift;
m/^ =type \s+ (.+) /x && return $1 for $fld->comments;
my $type = $fld->dbf_type;
$type =~ s/^DBF_//;
return $type;
}
# Check if this field is readable
sub DBD::Recfield::readable {
my $fld = shift;
m/^ =read \s+ (?i) (Yes|No) /x && return $1 for $fld->comments;
return 'Probably'
if $fld->attribute('special') eq "SPC_DBADDR";
return $fld->dbf_type eq 'DBF_NOACCESS' ? 'No' : 'Yes';
}
# Check if this field is writable
sub DBD::Recfield::writable {
my $fld = shift;
m/^ =write \s+ (?i) (Yes|No) /x && return $1 for $fld->comments;
my $special = $fld->attribute('special');
return 'No'
if $special eq "SPC_NOMOD";
return 'Maybe'
if $special eq "SPC_DBADDR";
return $fld->dbf_type eq "DBF_NOACCESS" ? 'No' : 'Yes';
}
modules/database/src/tools/dbdToMenuH.pl
+80
View File
@@ -0,0 +1,80 @@
#!/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.
#*************************************************************************
use FindBin qw($Bin);
use lib ($Bin, "$Bin/../../lib/perl");
use databaseModuleDirs;
no lib $Bin;
use EPICS::Getopts;
use File::Basename;
use DBD;
use DBD::Parser;
use EPICS::macLib;
use EPICS::Readfile;
my $tool = 'dbdToMenuH.pl';
use vars qw($opt_D @opt_I $opt_o $opt_s);
getopts('DI@o:') or
die "Usage: $tool: [-D] [-I dir] [-o menu.h] menu.dbd [menu.h]\n";
my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
my $dbd = DBD->new();
my $infile = shift @ARGV;
$infile =~ m/\.dbd$/ or
die "$tool: Input file '$infile' must have '.dbd' extension\n";
my $inbase = basename($infile);
my $outfile;
if ($opt_o) {
$outfile = $opt_o;
} elsif (@ARGV) {
$outfile = shift @ARGV;
} else {
($outfile = $infile) =~ s/\.dbd$/.h/;
$outfile =~ s/^.*\///;
}
my $outbase = basename($outfile);
# Derive a name for the include guard
my $guard_name = "INC_$outbase";
$guard_name =~ tr/a-zA-Z0-9_/_/cs;
$guard_name =~ s/(_[hH])?$/_H/;
ParseDBD($dbd, Readfile($infile, 0, \@opt_I));
if ($opt_D) {
my %filecount;
my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n";
print map { "$_:\n" } @uniqfiles;
} else {
open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n";
print OUTFILE "/* $outbase generated from $inbase */\n\n",
"#ifndef $guard_name\n",
"#define $guard_name\n\n";
my $menus = $dbd->menus;
while (my ($name, $menu) = each %{$menus}) {
print OUTFILE $menu->toDeclaration;
}
# FIXME: Where to put metadata for widely used menus?
# In the generated menu.h file is wrong: can't create a list of menu.h files.
# Can only rely on registerRecordDeviceDriver output, so we must require that
# all such menus be named "menu...", and any other menus must be defined in
# the record.dbd file that needs them.
# print OUTFILE "\n#ifdef GEN_MENU_METADATA\n\n";
# while (($name, $menu) = each %{$menus}) {
# print OUTFILE $menu->toDefinition;
# }
# print OUTFILE "\n#endif /* GEN_MENU_METADATA */\n";
print OUTFILE "\n#endif /* $guard_name */\n";
close OUTFILE;
}
modules/database/src/tools/dbdToRecordtypeH.pl
+232
View File
@@ -0,0 +1,232 @@
#!/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.
#*************************************************************************
use FindBin qw($Bin);
use lib ($Bin, "$Bin/../../lib/perl");
use databaseModuleDirs;
no lib $Bin;
use EPICS::Getopts;
use File::Basename;
use DBD;
use DBD::Parser;
use EPICS::macLib;
use EPICS::Readfile;
my $tool = 'dbdToRecordtypeH.pl';
use vars qw($opt_D @opt_I $opt_o $opt_s);
getopts('DI@o:s') or
die "Usage: $tool [-D] [-I dir] [-o xRecord.h] xRecord.dbd [xRecord.h]\n";
my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
my $dbd = DBD->new();
my $infile = shift @ARGV;
$infile =~ m/\.dbd$/ or
die "$tool: Input file '$infile' must have '.dbd' extension\n";
my $inbase = basename($infile);
my $outfile;
if ($opt_o) {
$outfile = $opt_o;
} elsif (@ARGV) {
$outfile = shift @ARGV;
} else {
($outfile = $infile) =~ s/\.dbd$/.h/;
$outfile =~ s/^.*\///;
$outfile =~ s/dbCommonRecord/dbCommon/;
}
my $outbase = basename($outfile);
# Derive a name for the include guard
my $guard_name = "INC_$outbase";
$guard_name =~ tr/a-zA-Z0-9_/_/cs;
$guard_name =~ s/(_[hH])?$/_H/;
ParseDBD($dbd, Readfile($infile, 0, \@opt_I));
my $rtypes = $dbd->recordtypes;
die "$tool: Input file must contain a single recordtype definition.\n"
unless (1 == keys %{$rtypes});
if ($opt_D) { # Output dependencies only, to stdout
my %filecount;
my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n";
print map { "$_:\n" } @uniqfiles;
} else {
open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n";
print OUTFILE "/* $outbase generated from $inbase */\n\n",
"#ifndef $guard_name\n",
"#define $guard_name\n\n";
our ($rn, $rtyp) = each %{$rtypes};
print OUTFILE $rtyp->toCdefs;
my @menu_fields = grep {
$_->dbf_type eq 'DBF_MENU'
} $rtyp->fields;
my %menu_used;
grep {
!$menu_used{$_}++
} map {
$_->attribute('menu')
} @menu_fields;
our $menus_defined = $dbd->menus;
while (my ($name, $menu) = each %{$menus_defined}) {
print OUTFILE $menu->toDeclaration;
if ($menu_used{$name}) {
delete $menu_used{$name}
}
}
our @menus_external = keys %menu_used;
print OUTFILE $rtyp->toDeclaration;
unless ($rn eq 'dbCommon') {
my $n = 0;
print OUTFILE "typedef enum {\n",
join(",\n",
map { "\t${rn}Record$_ = " . $n++ } $rtyp->field_names),
"\n} ${rn}FieldIndex;\n\n";
print OUTFILE "#ifdef GEN_SIZE_OFFSET\n\n";
if ($opt_s) {
newtables();
} else {
oldtables();
}
print OUTFILE "#endif /* GEN_SIZE_OFFSET */\n";
}
print OUTFILE "\n",
"#endif /* $guard_name */\n";
close OUTFILE;
}
sub oldtables {
# Output compatible with R3.14.x
print OUTFILE
"#include <epicsAssert.h>\n" .
"#include <epicsExport.h>\n" .
"#ifdef __cplusplus\n" .
"extern \"C\" {\n" .
"#endif\n" .
"static int ${rn}RecordSizeOffset(dbRecordType *prt)\n" .
"{\n" .
" ${rn}Record *prec = 0;\n\n" .
" assert(prt->no_fields == " . scalar($rtyp->fields) . ");\n" .
join("\n", map {
" prt->papFldDes[${rn}Record" . $_->name . "]->size = " .
"sizeof(prec->" . $_->C_name . ");"
} $rtyp->fields) . "\n" .
join("\n", map {
" prt->papFldDes[${rn}Record" . $_->name . "]->offset = (unsigned short)(" .
"(char *)&prec->" . $_->C_name . " - (char *)prec);"
} $rtyp->fields) . "\n" .
" prt->rec_size = sizeof(*prec);\n" .
" return 0;\n" .
"}\n" .
"epicsExportRegistrar(${rn}RecordSizeOffset);\n\n" .
"#ifdef __cplusplus\n" .
"}\n" .
"#endif\n";
}
sub newtables {
# Output for an eventual DBD-less IOC
print OUTFILE (map {
"extern const dbMenu ${_}MenuMetaData;\n"
} @menus_external), "\n";
while (my ($name, $menu) = each %{$menus_defined}) {
print OUTFILE $menu->toDefinition;
}
print OUTFILE (map {
"static const char ${rn}FieldName$_\[] = \"$_\";\n" }
$rtyp->field_names), "\n";
my $n = 0;
print OUTFILE "static const dbRecordData ${rn}RecordMetaData;\n\n",
"static dbFldDes ${rn}FieldMetaData[] = {\n",
join(",\n", map {
my $fn = $_->name;
my $cn = $_->C_name;
" { ${rn}FieldName${fn}," .
$_->dbf_type . ',"' .
$_->attribute('initial') . '",' .
($_->attribute('special') || '0') . ',' .
($_->attribute('pp') || 'FALSE') . ',' .
($_->attribute('interest') || '0') . ',' .
($_->attribute('asl') || 'ASL0') . ',' .
$n++ . ",\n\t\&${rn}RecordMetaData," .
"GEOMETRY_DATA(${rn}Record,$cn) }";
} $rtyp->fields),
"\n};\n\n";
print OUTFILE "static const ${rn}FieldIndex ${rn}RecordLinkFieldIndices[] = {\n",
join(",\n", map {
" ${rn}Record" . $_->name;
} grep {
$_->dbf_type =~ m/^DBF_(IN|OUT|FWD)LINK/;
} $rtyp->fields),
"\n};\n\n";
my @sorted_names = sort $rtyp->field_names;
print OUTFILE "static const char * const ${rn}RecordSortedFieldNames[] = {\n",
join(",\n", map {
" ${rn}FieldName$_"
} @sorted_names),
"\n};\n\n";
print OUTFILE "static const ${rn}FieldIndex ${rn}RecordSortedFieldIndices[] = {\n",
join(",\n", map {
" ${rn}Record$_"
} @sorted_names),
"\n};\n\n";
print OUTFILE "extern rset ${rn}RSET;\n\n",
"static const dbRecordData ${rn}RecordMetaData = {\n",
" \"$rn\",\n",
" sizeof(${rn}Record),\n",
" NELEMENTS(${rn}FieldMetaData),\n",
" ${rn}FieldMetaData,\n",
" ${rn}RecordVAL,\n",
" \&${rn}FieldMetaData[${rn}RecordVAL],\n",
" NELEMENTS(${rn}RecordLinkFieldIndices),\n",
" ${rn}RecordLinkFieldIndices,\n",
" ${rn}RecordSortedFieldNames,\n",
" ${rn}RecordSortedFieldIndices,\n",
" \&${rn}RSET\n",
"};\n\n",
"#ifdef __cplusplus\n",
"extern \"C\" {\n",
"#endif\n\n";
print OUTFILE "dbRecordType * epicsShareAPI ${rn}RecordRegistrar(dbBase *pbase, int nDevs)\n",
"{\n",
" dbRecordType *prt = dbCreateRecordtype(&${rn}RecordMetaData, nDevs);\n";
print OUTFILE " ${rn}FieldMetaData[${rn}RecordDTYP].typDat.pdevMenu = \&prt->devMenu;\n";
while (my ($name, $menu) = each %{$menus_defined}) {
print OUTFILE " dbRegisterMenu(pbase, \&${name}MenuMetaData);\n";
}
print OUTFILE map {
" ${rn}FieldMetaData[${rn}Record" .
$_->name .
"].typDat.pmenu = \n".
" \&" .
$_->attribute('menu') .
"MenuMetaData;\n";
} @menu_fields;
print OUTFILE map {
" ${rn}FieldMetaData[${rn}Record" .
$_->name .
"].typDat.base = CT_HEX;\n";
} grep {
$_->attribute('base') eq 'HEX';
} $rtyp->fields;
print OUTFILE " dbRegisterRecordtype(pbase, prt);\n";
print OUTFILE " return prt;\n}\n\n",
"#ifdef __cplusplus\n",
"} /* extern \"C\" */\n",
"#endif\n\n";
}
modules/database/src/tools/makeIncludeDbd.pl
+33
View File
@@ -0,0 +1,33 @@
#!/usr/bin/env perl
#*************************************************************************
# Copyright (c) 2014 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.
#*************************************************************************
use strict;
use File::Basename;
sub Usage {
my $txt = shift;
print "Usage: makeIncludeDbd.pl input file list ... outfile\n";
print "Error: $txt\n" if $txt;
exit 2;
}
Usage("No input files specified")
unless $#ARGV > 1;
my $target = pop @ARGV;
my @inputs = map { basename($_); } @ARGV;
open(my $OUT, '>', $target)
or die "$0: Can't create $target, $!\n";
print $OUT "# Generated file $target\n\n";
print $OUT map { "include \"$_\"\n"; } @inputs;
close $OUT;
modules/database/src/tools/registerRecordDeviceDriver.pl
+300
View File
@@ -0,0 +1,300 @@
#!/usr/bin/env perl
#*************************************************************************
# Copyright (c) 2012 UChicago Argonne LLC, as Operator of Argonne
# National Laboratory.
# Copyright (c) 2002 The Regents of the University of California, as
# Operator of Los Alamos National Laboratory.
# EPICS BASE is distributed subject to a Software License Agreement found
# in file LICENSE that is included with this distribution.
#*************************************************************************
use strict;
use FindBin qw($Bin);
use lib ($Bin, "$Bin/../../lib/perl");
use databaseModuleDirs;
no lib $Bin;
use DBD;
use DBD::Parser;
use EPICS::Readfile;
use EPICS::Path;
use EPICS::Getopts;
use Text::Wrap;
our ($opt_D, @opt_I, $opt_o, $opt_l);
getopts('Dlo:I@') or
die "Usage: registerRecordDeviceDriver [-D] [-l] [-o out.c] [-I dir] in.dbd subname [TOP]";
my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
my ($file, $subname, $bldTop) = @ARGV;
my $dbd = DBD->new();
ParseDBD($dbd, Readfile($file, "", \@path));
if ($opt_D) { # Output dependencies only
my %filecount;
my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
print "$opt_o: ", join(" \\\n ", @uniqfiles), "\n\n";
print map { "$_:\n" } @uniqfiles;
exit 0;
}
$Text::Wrap::columns = 75;
# Eliminate chars not allowed in C symbol names
my $c_bad_ident_chars = '[^0-9A-Za-z_]';
$subname =~ s/$c_bad_ident_chars/_/g;
# Process bldTop like convertRelease.pl does
$bldTop = LocalPath(UnixPath($bldTop));
$bldTop =~ s/([\\"])/\\\1/g; # escape back-slashes and double-quotes
# Create output file
my $out;
if ($opt_o) {
open $out, '>', $opt_o or die "Can't create $opt_o: $!\n";
} else {
$out = *STDOUT;
}
print $out (<< "END");
/* THIS IS A GENERATED FILE. DO NOT EDIT! */
/* Generated from $file */
#include <string.h>
#ifndef USE_TYPED_RSET
# define USE_TYPED_RSET
#endif
#include "compilerDependencies.h"
#include "epicsStdlib.h"
#include "iocsh.h"
#include "iocshRegisterCommon.h"
#include "registryCommon.h"
#include "recSup.h"
END
print $out (<< "END") if $opt_l;
#define epicsExportSharedSymbols
#include "shareLib.h"
END
print $out (<< "END");
extern "C" {
END
my %rectypes = %{$dbd->recordtypes};
my @rtypnames;
my @dsets;
if (%rectypes) {
my @allrtypnames = sort keys %rectypes;
# Record types with no fields defined are declarations,
# for building shared libraries containing device support.
@rtypnames = grep { scalar $rectypes{$_}->fields } @allrtypnames;
if (@rtypnames) {
# Declare the record support entry tables
print $out wrap('epicsShareExtern typed_rset ', ' ',
join(', ', map {"*pvar_rset_${_}RSET"} @rtypnames)), ";\n\n";
# Declare the RecordSizeOffset functions
print $out "typedef int (*rso_func)(dbRecordType *pdbRecordType);\n";
print $out wrap('epicsShareExtern rso_func ', ' ',
join(', ', map {"pvar_func_${_}RecordSizeOffset"} @rtypnames)), ";\n\n";
# List of record type names
print $out "static const char * const recordTypeNames[] = {\n";
print $out wrap(' ', ' ', join(', ', map {"\"$_\""} @rtypnames));
print $out "\n};\n\n";
# List of pointers to each RSET and RecordSizeOffset function
print $out "static const recordTypeLocation rtl[] = {\n";
print $out join(",\n", map {
" {(struct typed_rset *)pvar_rset_${_}RSET, pvar_func_${_}RecordSizeOffset}"
} @rtypnames);
print $out "\n};\n\n";
}
for my $rtype (@allrtypnames) {
my @devices = $rectypes{$rtype}->devices;
for my $dtype (@devices) {
my $dset = $dtype->name;
push @dsets, $dset;
}
}
if (@dsets) {
# Declare the device support entry tables
print $out wrap('epicsShareExtern dset ', ' ',
join(', ', map {"*pvar_dset_$_"} @dsets)), ";\n\n";
# List of dset names
print $out "static const char * const deviceSupportNames[] = {\n";
print $out wrap(' ', ' ', join(', ', map {"\"$_\""} @dsets));
print $out "\n};\n\n";
# List of pointers to each dset
print $out "static const dset * const devsl[] = {\n";
print $out wrap(' ', ' ', join(", ", map {"pvar_dset_$_"} @dsets));
print $out "\n};\n\n";
}
}
my %drivers = %{$dbd->drivers};
if (%drivers) {
my @drivers = sort keys %drivers;
# Declare the driver entry tables
print $out wrap('epicsShareExtern drvet ', ' ',
join(', ', map {"*pvar_drvet_$_"} @drivers)), ";\n\n";
# List of drvet names
print $out "static const char *driverSupportNames[] = {\n";
print $out wrap(' ', ' ', join(', ', map {"\"$_\""} @drivers));
print $out "};\n\n";
# List of pointers to each drvet
print $out "static struct drvet *drvsl[] = {\n";
print $out join(",\n", map {" pvar_drvet_$_"} @drivers);
print $out "};\n\n";
}
my %links = %{$dbd->links};
if (%links) {
my @links = sort keys %links;
# Declare the link interfaces
print $out wrap('epicsShareExtern jlif ', ' ',
join(', ', map {"*pvar_jlif_$_"} @links)), ";\n\n";
# List of pointers to each link interface
print $out "static struct jlif *jlifsl[] = {\n";
print $out join(",\n", map {" pvar_jlif_$_"} @links);
print $out "};\n\n";
}
my @registrars = sort keys %{$dbd->registrars};
my @functions = sort keys %{$dbd->functions};
push @registrars, map {"register_func_$_"} @functions;
if (@registrars) {
# Declare the registrar functions
print $out "typedef void (*reg_func)(void);\n";
print $out wrap('epicsShareExtern reg_func ', ' ',
join(', ', map {"pvar_func_$_"} @registrars)), ";\n\n";
}
my %variables = %{$dbd->variables};
if (%variables) {
my @varnames = sort keys %variables;
# Declare the variables
for my $var (@varnames) {
my $vtype = $variables{$var}->var_type;
print $out "epicsShareExtern $vtype * const pvar_${vtype}_$var;\n";
}
# Generate the structure for registering variables with iocsh
print $out "\nstatic struct iocshVarDef vardefs[] = {\n";
for my $var (@varnames) {
my $vtype = $variables{$var}->var_type;
my $itype = $variables{$var}->iocshArg_type;
print $out " {\"$var\", $itype, pvar_${vtype}_$var},\n";
}
print $out " {NULL, iocshArgInt, NULL}\n};\n\n";
}
# Now for actual registration routine
print $out (<< "END");
int $subname(DBBASE *pbase)
{
static int executed = 0;
END
print $out (<< "END") if $bldTop ne '';
const char *bldTop = "$bldTop";
const char *envTop = getenv("TOP");
if (envTop && strcmp(envTop, bldTop)) {
printf("Warning: IOC is booting with TOP = \\"%s\\"\\n"
" but was built with TOP = \\"%s\\"\\n",
envTop, bldTop);
}
END
print $out (<< 'END');
if (!pbase) {
printf("pdbbase is NULL; you must load a DBD file first.\n");
return -1;
}
if (executed) {
printf("Warning: Registration already done.\n");
}
executed = 1;
END
print $out (<< 'END') if %rectypes && @rtypnames;
registerRecordTypes(pbase, NELEMENTS(rtl), recordTypeNames, rtl);
END
print $out (<< 'END') if @dsets;
registerDevices(pbase, NELEMENTS(devsl), deviceSupportNames, devsl);
END
print $out (<< 'END') if %drivers;
registerDrivers(pbase, NELEMENTS(drvsl), driverSupportNames, drvsl);
END
print $out (<< 'END') if %links;
registerJLinks(pbase, NELEMENTS(jlifsl), jlifsl);
END
print $out (<< "END") for @registrars;
pvar_func_$_();
END
print $out (<< 'END') if %variables;
iocshRegisterVariable(vardefs);
END
print $out (<< "END");
return 0;
}
/* $subname */
static const iocshArg rrddArg0 = {"pdbbase", iocshArgPdbbase};
static const iocshArg *rrddArgs[] = {&rrddArg0};
static const iocshFuncDef rrddFuncDef =
{"$subname", 1, rrddArgs};
static void rrddCallFunc(const iocshArgBuf *)
{
$subname(*iocshPpdbbase);
}
} // extern "C"
/*
* Register commands on application startup
*/
static int Registration() {
iocshRegisterCommon();
iocshRegister(&rrddFuncDef, rrddCallFunc);
return 0;
}
static int done EPICS_UNUSED = Registration();
END
if ($opt_o) {
close $out or die "Closing $opt_o failed: $!\n";
}
exit 0;