Merged compiled-dbd branch.
This does all DBD-file processing at build-time in Perl scripts. The result should behave almost identically to the old programs.
This commit is contained in:
Andrew Johnson
@@ -0,0 +1,81 @@
|
||||
package DBD;
|
||||
|
||||
use DBD::Base;
|
||||
use DBD::Breaktable;
|
||||
use DBD::Driver;
|
||||
use DBD::Menu;
|
||||
use DBD::Recordtype;
|
||||
use DBD::Recfield;
|
||||
use DBD::Registrar;
|
||||
use DBD::Function;
|
||||
use DBD::Variable;
|
||||
|
||||
use Carp;
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
my $this = {
|
||||
'DBD::Breaktable' => {},
|
||||
'DBD::Driver' => {},
|
||||
'DBD::Function' => {},
|
||||
'DBD::Menu' => {},
|
||||
'DBD::Recordtype' => {},
|
||||
'DBD::Registrar' => {},
|
||||
'DBD::Variable' => {}
|
||||
};
|
||||
bless $this, $class;
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub add {
|
||||
my ($this, $obj) = @_;
|
||||
my $obj_class;
|
||||
foreach (keys %{$this}) {
|
||||
next unless m/^DBD::/;
|
||||
$obj_class = $_ and last if $obj->isa($_);
|
||||
}
|
||||
confess "Unknown object type"
|
||||
unless defined $obj_class;
|
||||
my $obj_name = $obj->name;
|
||||
dieContext("Duplicate name '$obj_name'")
|
||||
if exists $this->{$obj_class}->{$obj_name};
|
||||
$this->{$obj_class}->{$obj_name} = $obj;
|
||||
}
|
||||
|
||||
sub breaktables {
|
||||
return shift->{'DBD::Breaktable'};
|
||||
}
|
||||
|
||||
sub drivers {
|
||||
return shift->{'DBD::Driver'};
|
||||
}
|
||||
|
||||
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 registrars {
|
||||
return shift->{'DBD::Registrar'};
|
||||
}
|
||||
|
||||
sub variables {
|
||||
return shift->{'DBD::Variable'};
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,127 @@
|
||||
# Common utility functions used by the DBD components
|
||||
|
||||
package DBD::Base;
|
||||
|
||||
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 $RXident = qr/ [a-zA-Z] [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;
|
||||
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 $RXstr = qr/ ( $RXname | $RXnum | $RXdqs | $RXsqs ) /ox;
|
||||
|
||||
our @context;
|
||||
|
||||
|
||||
sub pushContext {
|
||||
my ($ctxt) = @_;
|
||||
unshift @context, $ctxt;
|
||||
}
|
||||
|
||||
sub popContext {
|
||||
my ($ctxt) = @_;
|
||||
my ($pop) = shift @context;
|
||||
($ctxt ne $pop) and
|
||||
dieContext("Exiting context \"$ctxt\", found \"$pop\" instead.",
|
||||
"\tBraces must close in the same file they were opened.");
|
||||
}
|
||||
|
||||
sub dieContext {
|
||||
my ($msg) = join "\n\t", @_;
|
||||
print "$msg\n" if $msg;
|
||||
die "Context: ", join(' in ', @context), "\n";
|
||||
}
|
||||
|
||||
sub warnContext {
|
||||
my ($msg) = join "\n\t", @_;
|
||||
print "$msg\n" if $msg;
|
||||
print "Context: ", join(' in ', @context), "\n";
|
||||
}
|
||||
|
||||
|
||||
# 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
|
||||
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 ($id, $what) = @_;
|
||||
unquote $id;
|
||||
confess "$what undefined!" unless defined $id;
|
||||
$id =~ m/^$RXident$/o 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 {
|
||||
($_) = @_;
|
||||
# How to do this?
|
||||
return $_;
|
||||
}
|
||||
|
||||
|
||||
# Base class routines 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} = identifier($name, $what);
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub name {
|
||||
return shift->{NAME};
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,32 @@
|
||||
package DBD::Breaktable;
|
||||
use DBD::Base;
|
||||
@ISA = qw(DBD::Base);
|
||||
|
||||
use Carp;
|
||||
|
||||
sub init {
|
||||
my ($this, $name) = @_;
|
||||
$this->SUPER::init($name, "breakpoint table name");
|
||||
$this->{POINT_LIST} = [];
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub add_point {
|
||||
my ($this, $raw, $eng) = @_;
|
||||
confess "Raw value undefined!" unless defined $raw;
|
||||
confess "Engineering value undefined!" unless defined $eng;
|
||||
unquote $raw;
|
||||
unquote $eng;
|
||||
push @{$this->{POINT_LIST}}, [$raw, $eng];
|
||||
}
|
||||
|
||||
sub points {
|
||||
return @{shift->{POINT_LIST}};
|
||||
}
|
||||
|
||||
sub point {
|
||||
my ($this, $idx) = @_;
|
||||
return $this->{POINT_LIST}[$idx];
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,45 @@
|
||||
package DBD::Device;
|
||||
use DBD::Base;
|
||||
@ISA = qw(DBD::Base);
|
||||
|
||||
my %link_types = (
|
||||
CONSTANT => qr/$RXnum/o,
|
||||
PV_LINK => qr/$RXname \s+ [.NPCAMS ]*/ox,
|
||||
VME_IO => qr/\# (?: \s* [CS] \s* $RXintx)* \s* (?: @ .*)?/ox,
|
||||
CAMAC_IO => qr/\# (?: \s* [BCNAF] \s* $RXintx)* \s* (?: @ .*)?/ox,
|
||||
RF_IO => qr/\# (?: \s* [RMDE] \s* $RXintx)*/ox,
|
||||
AB_IO => qr/\# (?: \s* [LACS] \s* $RXintx)* \s* (?: @ .*)?/ox,
|
||||
GPIB_IO => qr/\# (?: \s* [LA] \s* $RXintx)* \s* (?: @ .*)?/ox,
|
||||
BITBUS_IO => qr/\# (?: \s* [LNPS] \s* $RXuintx)* \s* (?: @ .*)?/ox,
|
||||
BBGPIB_IO => qr/\# (?: \s* [LBG] \s* $RXuintx)* \s* (?: @ .*)?/ox,
|
||||
VXI_IO => qr/\# (?: \s* [VCS] \s* $RXintx)* \s* (?: @ .*)?/ox,
|
||||
INST_IO => qr/@.*/
|
||||
);
|
||||
|
||||
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, "DSET name");
|
||||
$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}};
|
||||
unquote $addr;
|
||||
return $addr =~ m/^ $rx $/x;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,9 @@
|
||||
package DBD::Driver;
|
||||
use DBD::Base;
|
||||
@ISA = qw(DBD::Base);
|
||||
|
||||
sub init {
|
||||
return shift->SUPER::init(shift, "driver entry table name");
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,10 @@
|
||||
package DBD::Function;
|
||||
use DBD::Base;
|
||||
@ISA = qw(DBD::Base);
|
||||
|
||||
sub init {
|
||||
return shift->SUPER::init(shift, "function name");
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -0,0 +1,66 @@
|
||||
package DBD::Menu;
|
||||
use DBD::Base;
|
||||
@ISA = qw(DBD::Base);
|
||||
|
||||
sub init {
|
||||
my ($this, $name) = @_;
|
||||
$this->SUPER::init($name, "menu name");
|
||||
$this->{CHOICE_LIST} = [];
|
||||
$this->{CHOICE_INDEX} = {};
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub add_choice {
|
||||
my ($this, $name, $value) = @_;
|
||||
$name = identifier($name, "Choice name");
|
||||
unquote $value;
|
||||
foreach $pair ($this->choices) {
|
||||
dieContext("Duplicate choice name") if ($pair->[0] eq $name);
|
||||
dieContext("Duplicate choice string") 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) = @_;
|
||||
unquote $value;
|
||||
return exists $this->{CHOICE_INDEX}->{$value};
|
||||
}
|
||||
|
||||
sub toDeclaration {
|
||||
my $this = shift;
|
||||
my $name = $this->name;
|
||||
my @choices = map {
|
||||
sprintf " %-31s /* %s */", @{$_}[0], escapeCcomment(@{$_}[1]);
|
||||
} $this->choices;
|
||||
return "typedef enum {\n" .
|
||||
join(",\n", @choices) .
|
||||
",\n ${name}_NUM_CHOICES\n" .
|
||||
"} $name;\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;
|
||||
@@ -0,0 +1,98 @@
|
||||
package DBD::Output;
|
||||
|
||||
require Exporter;
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(&OutputDBD);
|
||||
|
||||
use DBD;
|
||||
use DBD::Base;
|
||||
use DBD::Breaktable;
|
||||
use DBD::Device;
|
||||
use DBD::Driver;
|
||||
use DBD::Menu;
|
||||
use DBD::Recordtype;
|
||||
use DBD::Recfield;
|
||||
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);
|
||||
&OutputRegistrars($out, $dbd->registrars);
|
||||
&OutputFunctions($out, $dbd->functions);
|
||||
&OutputVariables($out, $dbd->variables);
|
||||
&OutputBreaktables($out, $dbd->breaktables);
|
||||
}
|
||||
|
||||
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 $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/^[a-zA-Z0-9_\-+:.\[\]<>;]*$/;
|
||||
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 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 " point(%s, %s)\n", @{$_}
|
||||
foreach $breaktable->points;
|
||||
print $out "}\n";
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,197 @@
|
||||
package DBD::Parser;
|
||||
require Exporter;
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(&ParseDBD);
|
||||
|
||||
use DBD;
|
||||
use DBD::Base;
|
||||
use DBD::Breaktable;
|
||||
use DBD::Device;
|
||||
use DBD::Driver;
|
||||
use DBD::Menu;
|
||||
use DBD::Recordtype;
|
||||
use DBD::Recfield;
|
||||
use DBD::Registrar;
|
||||
use DBD::Function;
|
||||
use DBD::Variable;
|
||||
|
||||
my $RXnam = qr/[a-zA-Z0-9_\-:.<>;]+/o;
|
||||
my $RXnum = qr/-? (?: \d+ ) | (?: \d* \. \d+ ) (?: [eE] [-+]? \d+ )?/ox;
|
||||
my $RXdqs = qr/" (?: [^"] | \\" )* "/ox;
|
||||
my $RXsqs = qr/' (?: [^'] | \\' )* '/ox;
|
||||
my $string = qr/ ( $RXnam | $RXnum | $RXdqs | $RXsqs ) /ox;
|
||||
|
||||
our $debug=0;
|
||||
|
||||
sub ParseDBD {
|
||||
my $dbd = shift;
|
||||
$_ = shift;
|
||||
while (1) {
|
||||
parseCommon();
|
||||
if (m/\G menu \s* \( \s* $string \s* \) \s* \{/oxgc) {
|
||||
print "Menu: $1\n" if $debug;
|
||||
parse_menu($dbd, $1);
|
||||
}
|
||||
elsif (m/\G driver \s* \( \s* $string \s* \)/oxgc) {
|
||||
print "Driver: $1\n" if $debug;
|
||||
$dbd->add(DBD::Driver->new($1));
|
||||
}
|
||||
elsif (m/\G registrar \s* \( \s* $string \s* \)/oxgc) {
|
||||
print "Registrar: $1\n" if $debug;
|
||||
$dbd->add(DBD::Registrar->new($1));
|
||||
}
|
||||
elsif (m/\G function \s* \( \s* $string \s* \)/oxgc) {
|
||||
print "Function: $1\n" if $debug;
|
||||
$dbd->add(DBD::Function->new($1));
|
||||
}
|
||||
elsif (m/\G breaktable \s* \( \s* $string \s* \) \s* \{/oxgc) {
|
||||
print "Breaktable: $1\n" if $debug;
|
||||
parse_breaktable($dbd, $1);
|
||||
}
|
||||
elsif (m/\G recordtype \s* \( \s* $string \s* \) \s* \{/oxgc) {
|
||||
print "Recordtype: $1\n" if $debug;
|
||||
parse_recordtype($dbd, $1);
|
||||
}
|
||||
elsif (m/\G variable \s* \( \s* $string \s* \)/oxgc) {
|
||||
print "Variable: $1\n" if $debug;
|
||||
$dbd->add(DBD::Variable->new($1, 'int'));
|
||||
}
|
||||
elsif (m/\G variable \s* \( \s* $string \s* , \s* $string \s* \)/oxgc) {
|
||||
print "Variable: $1, $2\n" if $debug;
|
||||
$dbd->add(DBD::Variable->new($1, $2));
|
||||
}
|
||||
elsif (m/\G device \s* \( \s* $string \s* , \s* $string \s* ,
|
||||
\s* $string \s* , \s*$string \s* \)/oxgc) {
|
||||
print "Device: $1, $2, $3, $4\n" if $debug;
|
||||
my $rtyp = $dbd->recordtype($1);
|
||||
dieContext("Unknown record type '$1'") unless defined $rtyp;
|
||||
$rtyp->add_device(DBD::Device->new($2, $3, $4));
|
||||
} else {
|
||||
last unless m/\G (.*) $/moxgc;
|
||||
dieContext("Syntax error in '$1'");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub parseCommon {
|
||||
while (1) {
|
||||
# Skip leading whitespace
|
||||
m/\G \s* /oxgc;
|
||||
|
||||
if (m/\G \# /oxgc) {
|
||||
if (m/\G \#!BEGIN\{ ( [^}]* ) \}!\#\# \n/oxgc) {
|
||||
print "File-Begin: $1\n" if $debug;
|
||||
pushContext("file '$1'");
|
||||
}
|
||||
elsif (m/\G \#!END\{ ( [^}]* ) \}!\#\# \n?/oxgc) {
|
||||
print "File-End: $1\n" if $debug;
|
||||
popContext("file '$1'");
|
||||
}
|
||||
else {
|
||||
m/\G (.*) \n/oxgc;
|
||||
print "Comment: $1\n" if $debug;
|
||||
}
|
||||
} else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub parse_menu {
|
||||
my ($dbd, $name) = @_;
|
||||
pushContext("menu($name)");
|
||||
my $menu = DBD::Menu->new($name);
|
||||
while(1) {
|
||||
parseCommon();
|
||||
if (m/\G choice \s* \( \s* $string \s* , \s* $string \s* \)/oxgc) {
|
||||
print " Menu-Choice: $1, $2\n" if $debug;
|
||||
$menu->add_choice($1, $2);
|
||||
}
|
||||
elsif (m/\G \}/oxgc) {
|
||||
print " Menu-End:\n" if $debug;
|
||||
$dbd->add($menu);
|
||||
popContext("menu($name)");
|
||||
return;
|
||||
} else {
|
||||
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
|
||||
dieContext("Syntax error in '$1'");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub parse_breaktable {
|
||||
my ($dbd, $name) = @_;
|
||||
pushContext("breaktable($name)");
|
||||
my $bt = DBD::Breaktable->new($name);
|
||||
while(1) {
|
||||
parseCommon();
|
||||
if (m/\G point\s* \(\s* $string \s* , \s* $string \s* \)/oxgc) {
|
||||
print " Breaktable-Point: $1, $2\n" if $debug;
|
||||
$bt->add_point($1, $2);
|
||||
}
|
||||
elsif (m/\G $string \s* (?: , \s*)? $string (?: \s* ,)?/oxgc) {
|
||||
print " Breaktable-Data: $1, $2\n" if $debug;
|
||||
$bt->add_point($1, $2);
|
||||
}
|
||||
elsif (m/\G \}/oxgc) {
|
||||
print " Breaktable-End:\n" if $debug;
|
||||
$dbd->add($bt);
|
||||
popContext("breaktable($name)");
|
||||
return;
|
||||
} else {
|
||||
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
|
||||
dieContext("Syntax error in '$1'");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub parse_recordtype {
|
||||
my ($dbd, $name) = @_;
|
||||
pushContext("recordtype($name)");
|
||||
my $rtyp = DBD::Recordtype->new($name);
|
||||
while(1) {
|
||||
parseCommon();
|
||||
if (m/\G field \s* \( \s* $string \s* , \s* $string \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;
|
||||
}
|
||||
elsif (m/\G % (.*) \n/oxgc) {
|
||||
print " Recordtype-Cdef: $1\n" if $debug;
|
||||
$rtyp->add_cdef($1);
|
||||
} else {
|
||||
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
|
||||
dieContext("Syntax error in '$1'");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub parse_field {
|
||||
my ($rtyp, $name, $field_type) = @_;
|
||||
my $fld = DBD::Recfield->new($name, $field_type);
|
||||
pushContext("field($name, $field_type)");
|
||||
while(1) {
|
||||
parseCommon();
|
||||
if (m/\G (\w+) \s* \( \s* $string \s* \)/oxgc) {
|
||||
print " Field-Attribute: $1, $2\n" if $debug;
|
||||
$fld->add_attribute($1, $2);
|
||||
}
|
||||
elsif (m/\G \}/oxgc) {
|
||||
print " Field-End:\n" if $debug;
|
||||
$rtyp->add_field($fld);
|
||||
popContext("field($name, $field_type)");
|
||||
return;
|
||||
} else {
|
||||
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
|
||||
dieContext("Syntax error in '$1'");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,436 @@
|
||||
package DBD::Recfield;
|
||||
use DBD::Base;
|
||||
@ISA = qw(DBD::Base);
|
||||
|
||||
# The hash value is a regexp that matches all legal values of this field
|
||||
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_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/^GUI_\w+$/,
|
||||
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$/o
|
||||
);
|
||||
|
||||
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) = @_;
|
||||
unquote $type;
|
||||
$this->SUPER::init($name, "record field name");
|
||||
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} = {};
|
||||
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) = @_;
|
||||
unquote $value;
|
||||
my $match = $field_attrs{$attr};
|
||||
dieContext("Unknown field attribute '$1', valid attributes are:",
|
||||
sort keys %field_attrs)
|
||||
unless defined $match;
|
||||
dieContext("Bad value '$value' for field '$attr' attribute")
|
||||
unless $value =~ m/$match/;
|
||||
$this->{ATTR_INDEX}->{$attr} = $value;
|
||||
}
|
||||
|
||||
sub attributes {
|
||||
return shift->{ATTR_INDEX};
|
||||
}
|
||||
|
||||
sub attribute {
|
||||
my ($this, $attr) = @_;
|
||||
return $this->attributes->{$attr};
|
||||
}
|
||||
|
||||
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));
|
||||
}
|
||||
|
||||
# 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_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;
|
||||
@@ -0,0 +1,100 @@
|
||||
package DBD::Recordtype;
|
||||
use DBD::Base;
|
||||
@ISA = qw(DBD::Base);
|
||||
|
||||
use Carp;
|
||||
|
||||
sub init {
|
||||
my $this = shift;
|
||||
$this->SUPER::init(@_);
|
||||
$this->{FIELD_LIST} = [];
|
||||
$this->{FIELD_INDEX} = {};
|
||||
$this->{DEVICE_LIST} = [];
|
||||
$this->{DEVICE_INDEX} = {};
|
||||
$this->{CDEFS} = [];
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub add_field {
|
||||
my ($this, $field) = @_;
|
||||
confess "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...
|
||||
my $this = shift;
|
||||
my @names = ();
|
||||
foreach ($this->fields) {
|
||||
push @names, $_->name
|
||||
}
|
||||
return @names;
|
||||
}
|
||||
|
||||
sub field {
|
||||
my ($this, $field_name) = @_;
|
||||
return $this->{FIELD_INDEX}->{$field_name};
|
||||
}
|
||||
|
||||
sub add_device {
|
||||
my ($this, $device) = @_;
|
||||
confess "Not a DBD::Device" unless $device->isa('DBD::Device');
|
||||
my $choice = $device->choice;
|
||||
if (exists $this->{DEVICE_INDEX}->{$choice}) {
|
||||
my @warning = ("Duplicate device type '$choice'");
|
||||
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);
|
||||
warnContext(@warning);
|
||||
return;
|
||||
}
|
||||
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_cdef {
|
||||
my ($this, $cdef) = @_;
|
||||
push @{$this->{CDEFS}}, $cdef;
|
||||
}
|
||||
|
||||
sub cdefs {
|
||||
return @{shift->{CDEFS}};
|
||||
}
|
||||
|
||||
sub toCdefs {
|
||||
return join("\n", shift->cdefs) . "\n\n";
|
||||
}
|
||||
|
||||
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;
|
||||
@@ -0,0 +1,11 @@
|
||||
package DBD::Registrar;
|
||||
use DBD::Base;
|
||||
@ISA = qw(DBD::Base);
|
||||
|
||||
sub init {
|
||||
return shift->SUPER::init(shift, "registrar function name");
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
@@ -0,0 +1,36 @@
|
||||
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) = @_;
|
||||
if (defined $type) {
|
||||
unquote $type;
|
||||
} else {
|
||||
$type = "int";
|
||||
}
|
||||
exists $valid_types{$type} or
|
||||
dieContext("Unknown variable type '$type', valid types are:",
|
||||
sort keys %valid_types);
|
||||
$this->SUPER::init($name, "variable name");
|
||||
$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}};
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,101 @@
|
||||
#*************************************************************************
|
||||
# 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$
|
||||
|
||||
package EPICS::Readfile;
|
||||
require 5.000;
|
||||
require Exporter;
|
||||
|
||||
use EPICS::macLib;
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(@inputfiles &Readfile);
|
||||
|
||||
our $debug=0;
|
||||
our @inputfiles;
|
||||
|
||||
sub slurp {
|
||||
my ($FILE, $Rpath) = @_;
|
||||
my @path = @{$Rpath};
|
||||
print "slurp($FILE):\n" if $debug;
|
||||
if ($FILE !~ m[/]) {
|
||||
foreach $dir (@path) {
|
||||
print " trying $dir/$FILE\n" if $debug;
|
||||
if (-r "$dir/$FILE") {
|
||||
$FILE = "$dir/$FILE";
|
||||
last;
|
||||
}
|
||||
}
|
||||
die "Can't find file '$FILE'\n" unless -r $FILE;
|
||||
}
|
||||
print " opening $FILE\n" if $debug;
|
||||
open FILE, "<$FILE" or die "Can't open $FILE: $!\n";
|
||||
push @inputfiles, $FILE;
|
||||
my @lines = ("##!BEGIN{$FILE}!##\n");
|
||||
# Consider replacing these markers with C pre-processor linemarkers.
|
||||
# See 'info cpp' * Preprocessor Output:: for details.
|
||||
push @lines, <FILE>;
|
||||
push @lines, "##!END{$FILE}!##\n";
|
||||
close FILE or die "Error closing $FILE: $!\n";
|
||||
print " read ", scalar @lines, " lines\n" if $debug;
|
||||
return join '', @lines;
|
||||
}
|
||||
|
||||
sub expandMacros {
|
||||
my ($macros, $input) = @_;
|
||||
return $input unless $macros;
|
||||
return $macros->expandString($input);
|
||||
}
|
||||
|
||||
sub splitPath {
|
||||
my ($path) = @_;
|
||||
my (@path) = split /[:;]/, $path;
|
||||
grep s/^$/./, @path;
|
||||
return @path;
|
||||
}
|
||||
|
||||
my $RXstr = qr/ " (?: [^"] | \\" )* "/ox;
|
||||
my $RXnam = qr/[a-zA-Z0-9_\-:.[\]<>;]+/o;
|
||||
my $string = qr/ ( $RXnam | $RXstr ) /ox;
|
||||
|
||||
sub unquote {
|
||||
my ($s) = @_;
|
||||
$s =~ s/^"(.*)"$/$1/o;
|
||||
return $s;
|
||||
}
|
||||
|
||||
sub Readfile {
|
||||
my ($file, $macros, $Rpath) = @_;
|
||||
print "Readfile($file)\n" if $debug;
|
||||
my $input = &expandMacros($macros, &slurp($file, $Rpath));
|
||||
my @input = split /\n/, $input;
|
||||
my @output;
|
||||
foreach (@input) {
|
||||
if (m/^ \s* include \s+ $string /ox) {
|
||||
$arg = &unquote($1);
|
||||
print " include $arg\n" if $debug;
|
||||
push @output, "##! include \"$arg\"";
|
||||
push @output, &Readfile($arg, $macros, $Rpath);
|
||||
} elsif (m/^ \s* addpath \s+ $string /ox) {
|
||||
$arg = &unquote($1);
|
||||
print " addpath $arg\n" if $debug;
|
||||
push @output, "##! addpath \"$arg\"";
|
||||
push @{$Rpath}, &splitPath($arg);
|
||||
} elsif (m/^ \s* path \s+ $string /ox) {
|
||||
$arg = &unquote($1);
|
||||
print " path $arg\n" if $debug;
|
||||
push @output, "##! path \"$arg\"";
|
||||
@{$Rpath} = &splitPath($arg);
|
||||
} else {
|
||||
push @output, $_;
|
||||
}
|
||||
}
|
||||
return join "\n", @output;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,251 @@
|
||||
#*************************************************************************
|
||||
# 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$
|
||||
|
||||
package EPICS::macLib::entry;
|
||||
|
||||
sub new ($$) {
|
||||
my $class = shift;
|
||||
my $this = {
|
||||
name => shift,
|
||||
type => shift,
|
||||
raw => '',
|
||||
val => '',
|
||||
visited => 0,
|
||||
error => 0,
|
||||
};
|
||||
bless $this, $class;
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub report ($) {
|
||||
my ($this) = @_;
|
||||
return unless defined $this->{raw};
|
||||
printf "%1s %-16s %-16s %s\n",
|
||||
($this->{error} ? '*' : ' '), $this->{name}, $this->{raw}, $this->{val};
|
||||
}
|
||||
|
||||
|
||||
package EPICS::macLib;
|
||||
|
||||
use Carp;
|
||||
|
||||
sub new ($@) {
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $this = {
|
||||
dirty => 0,
|
||||
noWarn => 0,
|
||||
macros => [{}], # [0] is current scope, [1] is parent etc.
|
||||
};
|
||||
bless $this, $class;
|
||||
$this->installList(@_);
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub installList ($@) {
|
||||
# Argument is a list of strings which are arguments to installMacros
|
||||
my $this = shift;
|
||||
while (@_) {
|
||||
$this->installMacros(shift);
|
||||
}
|
||||
}
|
||||
|
||||
sub installMacros ($$) {
|
||||
# Argument is a string: a=1,b="2",c,d='hello'
|
||||
my $this = shift;
|
||||
$_ = shift;
|
||||
until (defined pos($_) and pos($_) == length($_)) {
|
||||
m/\G \s* /xgc; # Skip whitespace
|
||||
if (m/\G ( [A-Za-z0-9_-]+ ) \s* /xgc) {
|
||||
my ($name, $val) = ($1);
|
||||
if (m/\G = \s* /xgc) {
|
||||
# The value follows, handle quotes and escapes
|
||||
until (pos($_) == length($_)) {
|
||||
if (m/\G , /xgc) { last; }
|
||||
elsif (m/\G ' ( ( [^'] | \\ ' )* ) ' /xgc) { $val .= $1; }
|
||||
elsif (m/\G " ( ( [^"] | \\ " )* ) " /xgc) { $val .= $1; }
|
||||
elsif (m/\G \\ ( . ) /xgc) { $val .= $1; }
|
||||
elsif (m/\G ( . ) /xgc) { $val .= $1; }
|
||||
else { die "How did I get here?"; }
|
||||
}
|
||||
$this->putValue($name, $val);
|
||||
} elsif (m/\G , /xgc or (pos($_) == length($_))) {
|
||||
$this->putValue($name, undef);
|
||||
} else {
|
||||
warn "How did I get here?";
|
||||
}
|
||||
} elsif (m/\G ( .* )/xgc) {
|
||||
croak "Can't find a macro definition in '$1'";
|
||||
} else {
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub putValue ($$$) {
|
||||
my ($this, $name, $raw) = @_;
|
||||
if (exists $this->{macros}[0]{$name}) {
|
||||
if (!defined $raw) {
|
||||
delete $this->{macros}[0]{$name};
|
||||
} else {
|
||||
$this->{macros}[0]{$name}{raw} = $raw;
|
||||
}
|
||||
} else {
|
||||
my $entry = EPICS::macLib::entry->new($name, 'macro');
|
||||
$entry->{raw} = $raw;
|
||||
$this->{macros}[0]{$name} = $entry;
|
||||
}
|
||||
$this->{dirty} = 1;
|
||||
}
|
||||
|
||||
sub pushScope ($) {
|
||||
my ($this) = @_;
|
||||
unshift @{$this->{macros}}, {};
|
||||
}
|
||||
|
||||
sub popScope ($) {
|
||||
my ($this) = @_;
|
||||
shift @{$this->{macros}};
|
||||
}
|
||||
|
||||
sub suppressWarning($$) {
|
||||
my ($this, $suppress) = @_;
|
||||
$this->{noWarn} = $suppress;
|
||||
}
|
||||
|
||||
sub expandString($$) {
|
||||
my ($this, $src) = @_;
|
||||
$this->_expand;
|
||||
my $entry = EPICS::macLib::entry->new($src, 'string');
|
||||
my $result = $this->_translate($entry, 0, $src);
|
||||
return $result unless $entry->{error};
|
||||
return $this->{noWarn} ? $result : undef;
|
||||
}
|
||||
|
||||
sub reportMacros ($) {
|
||||
my ($this) = @_;
|
||||
$this->_expand;
|
||||
print "Macro report\n============\n";
|
||||
foreach my $scope (@{$this->{macros}}) {
|
||||
foreach my $name (keys %{$scope}) {
|
||||
my $entry = $scope->{$name};
|
||||
$entry->report;
|
||||
}
|
||||
} continue {
|
||||
print " -- scope ends --\n";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Private routines, not intended for public use
|
||||
|
||||
sub _expand ($) {
|
||||
my ($this) = @_;
|
||||
return unless $this->{dirty};
|
||||
foreach my $scope (@{$this->{macros}}) {
|
||||
foreach my $name (keys %{$scope}) {
|
||||
my $entry = $scope->{$name};
|
||||
$entry->{val} = $this->_translate($entry, 1, $entry->{raw});
|
||||
}
|
||||
}
|
||||
$this->{dirty} = 0;
|
||||
}
|
||||
|
||||
sub _lookup ($$$$$) {
|
||||
my ($this, $name) = @_;
|
||||
foreach my $scope (@{$this->{macros}}) {
|
||||
if (exists $scope->{$name}) {
|
||||
return undef # Macro marked as deleted
|
||||
unless defined $scope->{$name}{raw};
|
||||
return $scope->{$name};
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub _translate ($$$$) {
|
||||
my ($this, $entry, $level, $str) = @_;
|
||||
return $this->_trans($entry, $level, '', \$str);
|
||||
}
|
||||
|
||||
sub _trans ($$$$$) {
|
||||
my ($this, $entry, $level, $term, $R) = @_;
|
||||
return $$R
|
||||
if (!defined $$R or
|
||||
$$R =~ m/\A [^\$]* \Z/x); # Short-circuit if no macros
|
||||
my $quote = 0;
|
||||
my $val;
|
||||
until (defined pos($$R) and pos($$R) == length($$R)) {
|
||||
if ($term and ($$R =~ m/\G (?= [$term] ) /xgc)) {
|
||||
last;
|
||||
}
|
||||
if ($$R =~ m/\G \$ ( [({] ) /xgc) {
|
||||
my $macEnd = $1;
|
||||
$macEnd =~ tr/({/)}/;
|
||||
my $name2 = $this->_trans($entry, $level+1, "=$macEnd", $R);
|
||||
my $entry2 = $this->_lookup($name2);
|
||||
if (!defined $entry2) { # Macro not found
|
||||
if ($$R =~ m/\G = /xgc) { # Use default value given
|
||||
$val .= $this->_trans($entry, $level+1, $macEnd, $R);
|
||||
} else {
|
||||
unless ($this->{noWarn}) {
|
||||
$entry->{error} = 1;
|
||||
printf STDERR "macLib: macro '%s' is undefined (expanding %s '%s')\n",
|
||||
$name2, $entry->{type}, $entry->{name};
|
||||
}
|
||||
$val .= "\$($name2)";
|
||||
}
|
||||
$$R =~ m/\G [$macEnd] /xgc; # Discard close bracket
|
||||
} else { # Macro found
|
||||
if ($entry2->{visited}) {
|
||||
$entry->{error} = 1;
|
||||
printf STDERR "macLib: %s '%s' is recursive (expanding %s '%s')\n",
|
||||
$entry->{type}, $entry->{name}, $entry2->{type}, $entry2->{name};
|
||||
$val .= "\$($name)";
|
||||
} else {
|
||||
if ($$R =~ m/\G = /xgc) { # Discard default value
|
||||
local $this->{noWarn} = 1; # Temporarily kill warnings
|
||||
$this->_trans($entry, $level+1, $macEnd, $R);
|
||||
}
|
||||
$$R =~ m/\G [$macEnd] /xgc; # Discard close bracket
|
||||
if ($this->{dirty}) { # Translate raw value
|
||||
$entry2->{visited} = 1;
|
||||
$val .= $this->_trans($entry, $level+1, '', \$entry2->{raw});
|
||||
$entry2->{visited} = 0;
|
||||
} else {
|
||||
$val .= $entry2->{val}; # Here's one I made earlier...
|
||||
}
|
||||
}
|
||||
}
|
||||
} elsif ($level > 0) { # Discard quotes and escapes
|
||||
if ($quote and $$R =~ m/\G $quote /xgc) {
|
||||
$quote = 0;
|
||||
} elsif ($$R =~ m/\G ( ['"] ) /xgc) {
|
||||
$quote = $1;
|
||||
} elsif ($$R =~ m/\G \\? ( . ) /xgc) {
|
||||
$val .= $1;
|
||||
} else {
|
||||
warn "How did I get here? level=$level";
|
||||
}
|
||||
} else { # Level 0
|
||||
if ($$R =~ m/\G \\ ( . ) /xgc) {
|
||||
$val .= "\\$1";
|
||||
} elsif ($$R =~ m/\G ( [^\\\$'")}]* ) /xgc) {
|
||||
$val .= $1;
|
||||
} elsif ($$R =~ m/\G ( . ) /xgc) {
|
||||
$val .= $1;
|
||||
} else {
|
||||
warn "How did I get here? level=$level";
|
||||
}
|
||||
}
|
||||
}
|
||||
return $val;
|
||||
}
|
||||
|
||||
1;
|
||||
+22
-1
@@ -1,5 +1,5 @@
|
||||
#*************************************************************************
|
||||
# Copyright (c) 2008 UChicago Argonne LLC, as Operator of Argonne
|
||||
# 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.
|
||||
@@ -14,7 +14,23 @@ TOOLS = $(TOP)/src/tools
|
||||
PERL_MODULES += EPICS/Copy.pm
|
||||
PERL_MODULES += EPICS/Path.pm
|
||||
PERL_MODULES += EPICS/Release.pm
|
||||
PERL_MODULES += EPICS/Readfile.pm
|
||||
PERL_MODULES += EPICS/Getopts.pm
|
||||
PERL_MODULES += EPICS/macLib.pm
|
||||
|
||||
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/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/Registrar.pm
|
||||
PERL_MODULES += DBD/Variable.pm
|
||||
|
||||
PERL_SCRIPTS += convertRelease.pl
|
||||
PERL_SCRIPTS += cvsclean.pl
|
||||
@@ -32,5 +48,10 @@ PERL_SCRIPTS += munch.pl
|
||||
PERL_SCRIPTS += replaceVAR.pl
|
||||
PERL_SCRIPTS += useManifestTool.pl
|
||||
|
||||
PERL_SCRIPTS += dbdToMenuH.pl
|
||||
PERL_SCRIPTS += dbdToRecordtypeH.pl
|
||||
PERL_SCRIPTS += dbdExpand.pl
|
||||
PERL_SCRIPTS += dbdToHtml.pl
|
||||
|
||||
include $(TOP)/configure/RULES
|
||||
|
||||
|
||||
Executable
+53
@@ -0,0 +1,53 @@
|
||||
#!/usr/bin/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 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;
|
||||
|
||||
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();
|
||||
|
||||
while (@ARGV) {
|
||||
&ParseDBD($dbd, &Readfile(shift @ARGV, $macros, \@opt_I));
|
||||
}
|
||||
|
||||
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 $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;
|
||||
Executable
+64
@@ -0,0 +1,64 @@
|
||||
#!/usr/bin/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 FindBin qw($Bin);
|
||||
use lib "$Bin/../../lib/perl";
|
||||
|
||||
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));
|
||||
|
||||
$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;
|
||||
}
|
||||
}
|
||||
@@ -0,0 +1,252 @@
|
||||
#!/usr/bin/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 FindBin qw($Bin);
|
||||
use lib "$Bin/../../lib/perl";
|
||||
|
||||
use DBD;
|
||||
use DBD::Parser;
|
||||
use EPICS::Getopts;
|
||||
use EPICS::macLib;
|
||||
use EPICS::Readfile;
|
||||
|
||||
my $tool = 'dbdToHtml';
|
||||
getopts('DI@o:') or
|
||||
die "Usage: $tool [-D] [-I dir] [-o xRecord.html] xRecord.dbd\n";
|
||||
|
||||
my @path = map { split /[:;]/ } @opt_I;
|
||||
my $dbd = DBD->new();
|
||||
|
||||
my $infile = shift @ARGV;
|
||||
$infile =~ m/\.dbd$/ or
|
||||
die "$tool: Input file '$infile' must have '.dbd' extension\n";
|
||||
|
||||
&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I));
|
||||
|
||||
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 $out;
|
||||
if ($opt_o) {
|
||||
$out = $opt_o;
|
||||
} else {
|
||||
($out = $infile) =~ s/\.dbd$/.html/;
|
||||
$out =~ s/^.*\///;
|
||||
$out =~ s/dbCommonRecord/dbCommon/;
|
||||
}
|
||||
open $out, '>', $opt_o or die "Can't create $opt_o: $!\n";
|
||||
|
||||
print $out "<h1>$infile</h1>\n";
|
||||
|
||||
my $rtypes = $dbd->recordtypes;
|
||||
|
||||
my ($rn, $rtyp) = each %{$rtypes};
|
||||
print $out "<h2>Record Name $rn</h2>\n";
|
||||
|
||||
my @fields = $rtyp->fields;
|
||||
|
||||
#create a Hash to store the table of field information for each GUI type
|
||||
%dbdTables = (
|
||||
"GUI_COMMON" => "",
|
||||
"GUI_COMMON" => "",
|
||||
"GUI_ALARMS" => "",
|
||||
"GUI_BITS1" => "",
|
||||
"GUI_BITS2" => "",
|
||||
"GUI_CALC" => "",
|
||||
"GUI_CLOCK" => "",
|
||||
"GUI_COMPRESS" => "",
|
||||
"GUI_CONVERT" => "",
|
||||
"GUI_DISPLAY" => "",
|
||||
"GUI_HIST" => "",
|
||||
"GUI_INPUTS" => "",
|
||||
"GUI_LINKS" => "",
|
||||
"GUI_MBB" => "",
|
||||
"GUI_MOTOR" => "",
|
||||
"GUI_OUTPUT" => "",
|
||||
"GUI_PID" => "",
|
||||
"GUI_PULSE" => "",
|
||||
"GUI_SELECT" => "",
|
||||
"GUI_SEQ1" => "",
|
||||
"GUI_SEQ2" => "",
|
||||
"GUI_SEQ3" => "",
|
||||
"GUI_SUB" => "",
|
||||
"GUI_TIMER" => "",
|
||||
"GUI_WAVE" => "",
|
||||
"GUI_SCAN" => "",
|
||||
"GUI_NONE" => ""
|
||||
);
|
||||
|
||||
|
||||
#Loop over all of the fields. Build a string that contains the table body
|
||||
#for each of the GUI Types based on which fields go with which GUI type.
|
||||
foreach $fVal (@fields) {
|
||||
my $pg = $fVal->attribute('promptgroup');
|
||||
while ( ($typ1, $content) = each %dbdTables) {
|
||||
if ( $pg eq $typ1 or ($pg eq "" and $typ1 eq "GUI_NONE")) {
|
||||
buildTableRow($fVal, $dbdTables{$typ1} );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#Write out each table
|
||||
while ( ($typ2, $content) = each %dbdTables) {
|
||||
printHtmlTable($typ2, $content);
|
||||
}
|
||||
|
||||
|
||||
#add a field to a table body. The specified field and table body are passed
|
||||
#in as parameters
|
||||
sub buildTableRow {
|
||||
my ( $fld, $outStr) = @_;
|
||||
$longDesc = " ";
|
||||
%htmlCellFmt = (
|
||||
rowStart => "<tr><td rowspan = \"2\">",
|
||||
nextCell => "</td><td>",
|
||||
endRow => "</td></tr>",
|
||||
nextRow => "<tr><td colspan = \"7\" align=left>"
|
||||
);
|
||||
my %cellFmt = %htmlCellFmt;
|
||||
my $rowStart = $cellFmt{rowStart};
|
||||
my $nextCell = $cellFmt{nextCell};
|
||||
my $endRow = $cellFmt{endRow};
|
||||
my $nextRow = $cellFmt{nextRow};
|
||||
$outStr = $outStr . $rowStart;
|
||||
$outStr = $outStr . $fld->name;
|
||||
$outStr = $outStr . $nextCell;
|
||||
$outStr = $outStr . $fld->attribute('prompt');
|
||||
$outStr = $outStr . $nextCell;
|
||||
my $recType = $fld->dbf_type;
|
||||
$typStr = $recType;
|
||||
if ($recType eq "DBF_STRING") {
|
||||
$typStr = $recType . " [" . $fld->attribute('size') . "]";
|
||||
}
|
||||
|
||||
$outStr = $outStr . $typStr;
|
||||
$outStr = $outStr . $nextCell;
|
||||
$outStr = $outStr . design($fld);
|
||||
$outStr = $outStr . $nextCell;
|
||||
my $initial = $fld->attribute('initial');
|
||||
if ( $initial eq '' ) {$initial = " ";}
|
||||
$outStr = $outStr . $initial;
|
||||
$outStr = $outStr . $nextCell;
|
||||
$outStr = $outStr . readable($fld);
|
||||
$outStr = $outStr . $nextCell;
|
||||
$outStr = $outStr . writable($fld);
|
||||
$outStr = $outStr . $nextCell;
|
||||
$outStr = $outStr . processPassive($fld);
|
||||
$outStr = $outStr . $endRow;
|
||||
$outStr = $outStr . "\n";
|
||||
$outStr = $outStr . $nextRow;
|
||||
$outStr = $outStr . $longDesc;
|
||||
$outStr = $outStr . $endRow;
|
||||
$outStr = $outStr . "\n";
|
||||
$_[1] = $outStr;
|
||||
}
|
||||
|
||||
#Check if the prompt group is defined so that this can be used by clients
|
||||
sub design {
|
||||
my $fld = $_[0];
|
||||
my $pg = $fld->attribute('promptgroup');
|
||||
if ( $pg eq '' ) {
|
||||
my $result = 'No';
|
||||
}
|
||||
else {
|
||||
my $result = 'Yes';
|
||||
}
|
||||
}
|
||||
|
||||
#Check if this field is readable by clients
|
||||
sub readable {
|
||||
my $fld = $_[0];
|
||||
if ( $fld->attribute('special') eq "SPC_DBADDR") {
|
||||
$return = "Probably";
|
||||
}
|
||||
else{
|
||||
if ( $fld->dbf_type eq "DBF_NOACCESS" ) {
|
||||
$return = "No";
|
||||
}
|
||||
else {
|
||||
$return = "Yes"
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#Check if this field is writable by clients
|
||||
sub writable {
|
||||
my $fld = $_[0];
|
||||
my $spec = $fld->attribute('special');
|
||||
if ( $spec eq "SPC_NOMOD" ) {
|
||||
$return = "No";
|
||||
}
|
||||
else {
|
||||
if ( $spec ne "SPC_DBADDR") {
|
||||
if ( $fld->dbf_type eq "DBF_NOACCESS" ) {
|
||||
$return = "No";
|
||||
}
|
||||
else {
|
||||
$return = "Yes";
|
||||
}
|
||||
}
|
||||
else {
|
||||
$return = "Maybe";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
#Check to see if the field is process passive on caput
|
||||
sub processPassive {
|
||||
my $fld = $_[0];
|
||||
$pp = $fld->attribute('pp');
|
||||
if ( $pp eq "YES" or $pp eq "TRUE" ) {
|
||||
$result = "Yes";
|
||||
}
|
||||
elsif ( $PP eq "NO" or $pp eq "FALSE" or $pp eq "" ) {
|
||||
$result = "No";
|
||||
}
|
||||
}
|
||||
|
||||
#print the start row to define a table
|
||||
sub printTableStart {
|
||||
print $out "<table border =\"1\"> \n";
|
||||
print $out "<caption><em>$_[0]</em></caption>";
|
||||
print $out "<th>Field</th>\n";
|
||||
print $out "<th>Summary</th>\n";
|
||||
print $out "<th>Type</th>\n";
|
||||
print $out "<th>DCT</th>\n";
|
||||
print $out "<th>Default</th>\n";
|
||||
print $out "<th>Read</th>\n";
|
||||
print $out "<th>Write</th>\n";
|
||||
print $out "<th>caPut=PP</th></tr>\n";
|
||||
|
||||
}
|
||||
|
||||
#print the tail end of the table
|
||||
sub printTableEnd {
|
||||
print $out "</table>\n";
|
||||
}
|
||||
|
||||
# Print the table for a GUI type. The name of the GUI type and the Table body
|
||||
# for this type are fed in as parameters
|
||||
sub printHtmlTable {
|
||||
my ($typ2, $content) = $_;
|
||||
if ( (length $_[1]) gt 0) {
|
||||
printTableStart($_[0]);
|
||||
print $out "$_[1]\n";
|
||||
printTableEnd();
|
||||
}
|
||||
|
||||
}
|
||||
Executable
+80
@@ -0,0 +1,80 @@
|
||||
#!/usr/bin/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 FindBin qw($Bin);
|
||||
use lib "$Bin/../../lib/perl";
|
||||
|
||||
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;
|
||||
}
|
||||
Executable
+231
@@ -0,0 +1,231 @@
|
||||
#!/usr/bin/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 FindBin qw($Bin);
|
||||
use lib "$Bin/../../lib/perl";
|
||||
|
||||
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}
|
||||
} else {
|
||||
warn "Menu '$name' defined but not used\n";
|
||||
}
|
||||
}
|
||||
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 "#ifdef __cplusplus\n" .
|
||||
"extern \"C\" {\n" .
|
||||
"#endif\n" .
|
||||
"#include <epicsExport.h>\n" .
|
||||
"static int ${rn}RecordSizeOffset(dbRecordType *prt)\n" .
|
||||
"{\n" .
|
||||
" ${rn}Record *prec = 0;\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 = " .
|
||||
"(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";
|
||||
}
|
||||
@@ -0,0 +1,22 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use FindBin qw($Bin);
|
||||
use lib "$Bin/../../../../lib/perl";
|
||||
|
||||
use Test::More tests => 9;
|
||||
|
||||
use DBD::Breaktable;
|
||||
|
||||
my $bpt = DBD::Breaktable->new('test');
|
||||
isa_ok $bpt, 'DBD::Breaktable';
|
||||
is $bpt->name, 'test', 'Breakpoint table name';
|
||||
is $bpt->points, 0, 'Points == zero';
|
||||
$bpt->add_point(0, 0.5);
|
||||
is $bpt->points, 1, 'First point added';
|
||||
is_deeply $bpt->point(0), [0, 0.5], 'First point correct';
|
||||
$bpt->add_point(1, 1.5);
|
||||
is $bpt->points, 2, 'Second point added';
|
||||
is_deeply $bpt->point(0), [0, 0.5], 'First point still correct';
|
||||
is_deeply $bpt->point(1), [1, 1.5], 'Second point correct';
|
||||
is_deeply $bpt->point(2), undef, 'Third point undefined';
|
||||
|
||||
@@ -0,0 +1,60 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use FindBin qw($Bin);
|
||||
use lib "$Bin/../../../../lib/perl";
|
||||
|
||||
use Test::More tests => 18;
|
||||
|
||||
use DBD;
|
||||
|
||||
my $dbd = DBD->new;
|
||||
isa_ok $dbd, 'DBD';
|
||||
|
||||
is keys %{$dbd->breaktables}, 0, 'No breaktables yet';
|
||||
my $brk = DBD::Breaktable->new('Brighton');
|
||||
$dbd->add($brk);
|
||||
my %brks = %{$dbd->breaktables};
|
||||
is_deeply \%brks, {Brighton => $brk}, 'Added breaktable';
|
||||
|
||||
is keys %{$dbd->drivers}, 0, 'No drivers yet';
|
||||
my $drv = DBD::Driver->new('Danforth');
|
||||
$dbd->add($drv);
|
||||
my %drvs = %{$dbd->drivers};
|
||||
is_deeply \%drvs, {Danforth => $drv}, 'Added driver';
|
||||
|
||||
is keys %{$dbd->functions}, 0, 'No functions yet';
|
||||
my $fnc = DBD::Function->new('Frank');
|
||||
$dbd->add($fnc);
|
||||
my %fncs = %{$dbd->functions};
|
||||
is_deeply \%fncs, {Frank => $fnc}, 'Added function';
|
||||
|
||||
is keys %{$dbd->menus}, 0, 'No menus yet';
|
||||
my $menu = DBD::Menu->new('Mango');
|
||||
$dbd->add($menu);
|
||||
my %menus = %{$dbd->menus};
|
||||
is_deeply \%menus, {Mango => $menu}, 'Added menu';
|
||||
is $dbd->menu('Mango'), $menu, 'Named menu';
|
||||
|
||||
is keys %{$dbd->recordtypes}, 0, 'No recordtypes yet';
|
||||
my $rtyp = DBD::Recordtype->new('Rita');
|
||||
$dbd->add($rtyp);
|
||||
my %rtypes = %{$dbd->recordtypes};
|
||||
is_deeply \%rtypes, {Rita => $rtyp}, 'Added recordtype';
|
||||
is $dbd->recordtype('Rita'), $rtyp, 'Named recordtype';
|
||||
|
||||
is keys %{$dbd->registrars}, 0, 'No registrars yet';
|
||||
my $reg = DBD::Registrar->new('Reggie');
|
||||
$dbd->add($reg);
|
||||
my %regs = %{$dbd->registrars};
|
||||
is_deeply \%regs, {Reggie => $reg}, 'Added registrar';
|
||||
|
||||
is keys %{$dbd->variables}, 0, 'No variables yet';
|
||||
my $ivar = DBD::Variable->new('IntVar');
|
||||
my $dvar = DBD::Variable->new('DblVar', 'double');
|
||||
$dbd->add($ivar);
|
||||
my %vars = %{$dbd->variables};
|
||||
is_deeply \%vars, {IntVar => $ivar}, 'First variable';
|
||||
$dbd->add($dvar);
|
||||
%vars = %{$dbd->variables};
|
||||
is_deeply \%vars, {IntVar => $ivar, DblVar => $dvar}, 'Second variable';
|
||||
|
||||
@@ -0,0 +1,33 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use FindBin qw($Bin);
|
||||
use lib "$Bin/../../../../lib/perl";
|
||||
|
||||
use Test::More tests => 16;
|
||||
|
||||
use DBD::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';
|
||||
is $dev->choice, 'Device', 'Choice string';
|
||||
ok $dev->legal_addr('#C0xFEED S123 @xxx'), 'Address legal';
|
||||
my %dev_addrs = (
|
||||
CONSTANT => '12345',
|
||||
PV_LINK => 'Any:Record.NAME CPP.MS',
|
||||
VME_IO => '# C1 S2 @Anything',
|
||||
CAMAC_IO => '# B1 C2 N3 A4 F5 @Anything',
|
||||
RF_IO => '# R1 M2 D3 E4',
|
||||
AB_IO => '# L1 A2 C3 S4 @Anything',
|
||||
GPIB_IO => '# L1 A2 @Anything',
|
||||
BITBUS_IO => '# L1 N2 P3 S4 @Anything',
|
||||
BBGPIB_IO => '# L1 B2 G3 @Anything',
|
||||
VXI_IO => '# V1 C2 S3 @Anything',
|
||||
INST_IO => '@Anything'
|
||||
);
|
||||
while (my ($link, $addr) = each(%dev_addrs)) {
|
||||
$dev->init($link, 'test', '"Device"');
|
||||
ok $dev->legal_addr($addr), "$link address";
|
||||
}
|
||||
|
||||
@@ -0,0 +1,13 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use FindBin qw($Bin);
|
||||
use lib "$Bin/../../../../lib/perl";
|
||||
|
||||
use Test::More tests => 2;
|
||||
|
||||
use DBD::Driver;
|
||||
|
||||
my $drv = DBD::Driver->new('test');
|
||||
isa_ok $drv, 'DBD::Driver';
|
||||
is $drv->name, 'test', 'Driver name';
|
||||
|
||||
@@ -0,0 +1,13 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use FindBin qw($Bin);
|
||||
use lib "$Bin/../../../../lib/perl";
|
||||
|
||||
use Test::More tests => 2;
|
||||
|
||||
use DBD::Function;
|
||||
|
||||
my $func = DBD::Function->new('test');
|
||||
isa_ok $func, 'DBD::Function';
|
||||
is $func->name, 'test', 'Function name';
|
||||
|
||||
@@ -0,0 +1,26 @@
|
||||
#*************************************************************************
|
||||
# Copyright (c) 2012 UChicago Argonne LLC, as Operator of Argonne
|
||||
# National Laboratory.
|
||||
# EPICS BASE is distributed subject to a Software License Agreement found
|
||||
# in the file LICENSE that is included with this distribution.
|
||||
#*************************************************************************
|
||||
TOP=../../..
|
||||
|
||||
include $(TOP)/configure/CONFIG
|
||||
|
||||
TESTS += Breaktable
|
||||
TESTS += DBD
|
||||
TESTS += Device
|
||||
TESTS += Driver
|
||||
TESTS += Function
|
||||
TESTS += macLib
|
||||
TESTS += Menu
|
||||
TESTS += Recfield
|
||||
TESTS += Recordtype
|
||||
TESTS += Registrar
|
||||
TESTS += Variable
|
||||
|
||||
TESTSCRIPTS_HOST += $(TESTS:%=%.t)
|
||||
|
||||
include $(TOP)/configure/RULES
|
||||
|
||||
@@ -0,0 +1,32 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use FindBin qw($Bin);
|
||||
use lib "$Bin/../../../../lib/perl";
|
||||
|
||||
use Test::More tests => 14;
|
||||
|
||||
use DBD::Menu;
|
||||
|
||||
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"');
|
||||
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"');
|
||||
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';
|
||||
ok $menu->legal_choice('Choice 2'), 'Second choice legal';
|
||||
is_deeply $menu->choice(1), ['ch2', 'Choice 2'], 'Second choice found';
|
||||
ok !$menu->legal_choice('Choice 3'), 'Third choice not legal';
|
||||
is_deeply $menu->choice(2), undef, 'Third choice undefined';
|
||||
|
||||
like $menu->toDeclaration, qr/ ^
|
||||
\s* typedef \s+ enum \s+ {
|
||||
\s+ ch1 \s+ \/\* [^*]* \*\/,
|
||||
\s+ ch2 \s+ \/\* [^*]* \*\/,
|
||||
\s+ test_NUM_CHOICES ,?
|
||||
\s+ } \s+ test; \s* $ /x, 'C declaration';
|
||||
@@ -0,0 +1,114 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use FindBin qw($Bin);
|
||||
use lib "$Bin/../../../../lib/perl";
|
||||
|
||||
use Test::More tests => 76;
|
||||
|
||||
use DBD::Recfield;
|
||||
|
||||
my $fld_string = DBD::Recfield->new('str', 'DBF_STRING');
|
||||
isa_ok $fld_string, 'DBD::Recfield';
|
||||
isa_ok $fld_string, 'DBD::Recfield::DBF_STRING';
|
||||
$fld_string->set_number(0);
|
||||
is $fld_string->number, 0, 'Field number';
|
||||
$fld_string->add_attribute("size", "41");
|
||||
is keys %{$fld_string->attributes}, 1, "Size set";
|
||||
ok $fld_string->legal_value("Hello, world!"), 'Legal value';
|
||||
ok !$fld_string->legal_value("x"x41), 'Illegal string';
|
||||
$fld_string->check_valid;
|
||||
like $fld_string->toDeclaration, qr/^\s*char\s+str\[41\];\s*$/, "C declaration";
|
||||
|
||||
my $fld_char = DBD::Recfield->new('chr', 'DBF_CHAR');
|
||||
isa_ok $fld_char, 'DBD::Recfield';
|
||||
isa_ok $fld_char, 'DBD::Recfield::DBF_CHAR';
|
||||
is $fld_char->name, 'chr', 'Field name';
|
||||
is $fld_char->dbf_type, 'DBF_CHAR', 'Field type';
|
||||
ok !$fld_char->legal_value("-129"), 'Illegal - value';
|
||||
ok $fld_char->legal_value("-128"), 'Legal - value';
|
||||
ok $fld_char->legal_value("127"), 'Legal + value';
|
||||
ok !$fld_char->legal_value("0x80"), 'Illegal + hex value';
|
||||
$fld_char->check_valid;
|
||||
like $fld_char->toDeclaration, qr/^\s*epicsInt8\s+chr;\s*$/, "C declaration";
|
||||
|
||||
my $fld_uchar = DBD::Recfield->new('uchr', 'DBF_UCHAR');
|
||||
isa_ok $fld_uchar, 'DBD::Recfield';
|
||||
isa_ok $fld_uchar, 'DBD::Recfield::DBF_UCHAR';
|
||||
is $fld_uchar->name, 'uchr', 'Field name';
|
||||
is $fld_uchar->dbf_type, 'DBF_UCHAR', 'Field type';
|
||||
ok !$fld_uchar->legal_value("-1"), 'Illegal - value';
|
||||
ok $fld_uchar->legal_value("0"), 'Legal 0 value';
|
||||
ok $fld_uchar->legal_value("0377"), 'Legal + value';
|
||||
ok !$fld_uchar->legal_value("0400"), 'Illegal + octal value';
|
||||
$fld_uchar->check_valid;
|
||||
like $fld_uchar->toDeclaration, qr/^\s*epicsUInt8\s+uchr;\s*$/, "C declaration";
|
||||
|
||||
my $fld_short = DBD::Recfield->new('shrt', 'DBF_SHORT');
|
||||
isa_ok $fld_short, 'DBD::Recfield';
|
||||
isa_ok $fld_short, 'DBD::Recfield::DBF_SHORT';
|
||||
is $fld_short->name, 'shrt', 'Field name';
|
||||
is $fld_short->dbf_type, 'DBF_SHORT', 'Field type';
|
||||
ok !$fld_short->legal_value("-32769"), 'Illegal - value';
|
||||
ok $fld_short->legal_value("-32768"), 'Legal - value';
|
||||
ok $fld_short->legal_value("32767"), 'Legal + value';
|
||||
ok !$fld_short->legal_value("0x8000"), 'Illegal + hex value';
|
||||
$fld_short->check_valid;
|
||||
like $fld_short->toDeclaration, qr/^\s*epicsInt16\s+shrt;\s*$/, "C declaration";
|
||||
|
||||
my $fld_ushort = DBD::Recfield->new('ushrt', 'DBF_USHORT');
|
||||
isa_ok $fld_ushort, 'DBD::Recfield';
|
||||
isa_ok $fld_ushort, 'DBD::Recfield::DBF_USHORT';
|
||||
is $fld_ushort->name, 'ushrt', 'Field name';
|
||||
is $fld_ushort->dbf_type, 'DBF_USHORT', 'Field type';
|
||||
ok !$fld_ushort->legal_value("-1"), 'Illegal - value';
|
||||
ok $fld_ushort->legal_value("0"), 'Legal 0 value';
|
||||
ok $fld_ushort->legal_value("65535"), 'Legal + value';
|
||||
ok !$fld_ushort->legal_value("0x10000"), 'Illegal + hex value';
|
||||
$fld_ushort->check_valid;
|
||||
like $fld_ushort->toDeclaration, qr/^\s*epicsUInt16\s+ushrt;\s*$/, "C declaration";
|
||||
|
||||
my $fld_long = DBD::Recfield->new('lng', 'DBF_LONG');
|
||||
isa_ok $fld_long, 'DBD::Recfield';
|
||||
isa_ok $fld_long, 'DBD::Recfield::DBF_LONG';
|
||||
is $fld_long->name, 'lng', 'Field name';
|
||||
is $fld_long->dbf_type, 'DBF_LONG', 'Field type';
|
||||
ok $fld_long->legal_value("-12345678"), 'Legal - value';
|
||||
ok $fld_long->legal_value("0x12345678"), 'Legal + value';
|
||||
ok !$fld_long->legal_value("0xfigure"), 'Illegal value';
|
||||
$fld_long->check_valid;
|
||||
like $fld_long->toDeclaration, qr/^\s*epicsInt32\s+lng;\s*$/, "C declaration";
|
||||
|
||||
my $fld_ulong = DBD::Recfield->new('ulng', 'DBF_ULONG');
|
||||
isa_ok $fld_ulong, 'DBD::Recfield';
|
||||
isa_ok $fld_ulong, 'DBD::Recfield::DBF_ULONG';
|
||||
is $fld_ulong->name, 'ulng', 'Field name';
|
||||
is $fld_ulong->dbf_type, 'DBF_ULONG', 'Field type';
|
||||
ok !$fld_ulong->legal_value("-1"), 'Illegal - value';
|
||||
ok $fld_ulong->legal_value("00"), 'Legal 0 value';
|
||||
ok $fld_ulong->legal_value("0xffffffff"), 'Legal + value';
|
||||
ok !$fld_ulong->legal_value("0xfacepaint"), 'Illegal value';
|
||||
$fld_ulong->check_valid;
|
||||
like $fld_ulong->toDeclaration, qr/^\s*epicsUInt32\s+ulng;\s*$/, "C declaration";
|
||||
|
||||
my $fld_float = DBD::Recfield->new('flt', 'DBF_FLOAT');
|
||||
isa_ok $fld_float, 'DBD::Recfield';
|
||||
isa_ok $fld_float, 'DBD::Recfield::DBF_FLOAT';
|
||||
is $fld_float->name, 'flt', 'Field name';
|
||||
is $fld_float->dbf_type, 'DBF_FLOAT', 'Field type';
|
||||
ok $fld_float->legal_value("-1.2345678e9"), 'Legal - value';
|
||||
ok $fld_float->legal_value("0.12345678e9"), 'Legal + value';
|
||||
ok !$fld_float->legal_value("0x1.5"), 'Illegal value';
|
||||
$fld_float->check_valid;
|
||||
like $fld_float->toDeclaration, qr/^\s*epicsFloat32\s+flt;\s*$/, "C declaration";
|
||||
|
||||
my $fld_double = DBD::Recfield->new('dbl', 'DBF_DOUBLE');
|
||||
isa_ok $fld_double, 'DBD::Recfield';
|
||||
isa_ok $fld_double, 'DBD::Recfield::DBF_DOUBLE';
|
||||
is $fld_double->name, 'dbl', 'Field name';
|
||||
is $fld_double->dbf_type, 'DBF_DOUBLE', 'Field type';
|
||||
ok $fld_double->legal_value("-12345e-67"), 'Legal - value';
|
||||
ok $fld_double->legal_value("12345678e+9"), 'Legal + value';
|
||||
ok !$fld_double->legal_value("e5"), 'Illegal value';
|
||||
$fld_double->check_valid;
|
||||
like $fld_double->toDeclaration, qr/^\s*epicsFloat64\s+dbl;\s*$/, "C declaration";
|
||||
|
||||
@@ -0,0 +1,57 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use FindBin qw($Bin);
|
||||
use lib "$Bin/../../../../lib/perl";
|
||||
|
||||
use Test::More tests => 17;
|
||||
|
||||
use DBD::Recordtype;
|
||||
use DBD::Recfield;
|
||||
use DBD::Device;
|
||||
|
||||
my $rtyp = DBD::Recordtype->new('test');
|
||||
isa_ok $rtyp, 'DBD::Recordtype';
|
||||
is $rtyp->name, 'test', 'Record name';
|
||||
is $rtyp->fields, 0, 'No fields yet';
|
||||
|
||||
my $fld1 = DBD::Recfield->new('NAME', 'DBF_STRING');
|
||||
$fld1->add_attribute("size", "41");
|
||||
$fld1->check_valid;
|
||||
|
||||
my $fld2 = DBD::Recfield->new('DTYP', 'DBF_DEVICE');
|
||||
$fld2->check_valid;
|
||||
|
||||
$rtyp->add_field($fld1);
|
||||
is $rtyp->fields, 1, 'First field added';
|
||||
|
||||
$rtyp->add_field($fld2);
|
||||
is $rtyp->fields, 2, 'Second field added';
|
||||
|
||||
my @fields = $rtyp->fields;
|
||||
is_deeply \@fields, [$fld1, $fld2], 'Field list';
|
||||
|
||||
my @names = $rtyp->field_names;
|
||||
is_deeply \@names, ['NAME', 'DTYP'], 'Field name list';
|
||||
|
||||
is $rtyp->field('NAME'), $fld1, 'Field name lookup';
|
||||
|
||||
is $fld1->number, 0, 'Field number 0';
|
||||
is $fld2->number, 1, 'Field number 1';
|
||||
|
||||
is $rtyp->devices, 0, 'No devices yet';
|
||||
|
||||
my $dev1 = DBD::Device->new('INST_IO', 'testDset', 'test device');
|
||||
$rtyp->add_device($dev1);
|
||||
is $rtyp->devices, 1, 'First device added';
|
||||
|
||||
my @devices = $rtyp->devices;
|
||||
is_deeply \@devices, [$dev1], 'Device list';
|
||||
|
||||
is $rtyp->device('test device'), $dev1, 'Device name lookup';
|
||||
|
||||
is $rtyp->cdefs, 0, 'No cdefs yet';
|
||||
$rtyp->add_cdef("cdef");
|
||||
is $rtyp->cdefs, 1, 'First cdef added';
|
||||
|
||||
my @cdefs = $rtyp->cdefs;
|
||||
is_deeply \@cdefs, ["cdef"], 'cdef list';
|
||||
@@ -0,0 +1,13 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use FindBin qw($Bin);
|
||||
use lib "$Bin/../../../../lib/perl";
|
||||
|
||||
use Test::More tests => 2;
|
||||
|
||||
use DBD::Registrar;
|
||||
|
||||
my $reg = DBD::Registrar->new('test');
|
||||
isa_ok $reg, 'DBD::Registrar';
|
||||
is $reg->name, 'test', 'Registrar name';
|
||||
|
||||
@@ -0,0 +1,15 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use FindBin qw($Bin);
|
||||
use lib "$Bin/../../../../lib/perl";
|
||||
|
||||
use Test::More tests => 4;
|
||||
|
||||
use DBD::Variable;
|
||||
|
||||
my $ivar = DBD::Variable->new('test');
|
||||
isa_ok $ivar, 'DBD::Variable';
|
||||
is $ivar->name, 'test', 'Variable name';
|
||||
is $ivar->var_type, 'int', 'variable defaults to int';
|
||||
my $dvar = DBD::Variable->new('test', 'double');
|
||||
is $dvar->var_type, 'double', 'double variable';
|
||||
@@ -0,0 +1,72 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use FindBin qw($Bin);
|
||||
use lib "$Bin/../../../../lib/perl";
|
||||
|
||||
use Test::More tests => 34;
|
||||
|
||||
use EPICS::macLib;
|
||||
|
||||
use Data::Dumper;
|
||||
|
||||
my $m = EPICS::macLib->new;
|
||||
isa_ok $m, 'EPICS::macLib';
|
||||
is $m->expandString(''), '', 'Empty string';
|
||||
is $m->expandString('$(undef)'), undef, 'Warning $(undef)';
|
||||
|
||||
$m->suppressWarning(1);
|
||||
is $m->expandString('$(undef)'), '$(undef)', 'Suppressed $(undef)';
|
||||
|
||||
$m->putValue('a', 'foo');
|
||||
is $m->expandString('$(a)'), 'foo', '$(a)';
|
||||
is $m->expandString('${a}'), 'foo', '${a}';
|
||||
is $m->expandString('$(a=bar)'), 'foo', '$(a=bar)';
|
||||
is $m->expandString('${a=bar}'), 'foo', '${a=bar}';
|
||||
is $m->expandString('$(undef)'), '$(undef)', '$(undef) again';
|
||||
is $m->expandString('${undef}'), '$(undef)', '${undef} again';
|
||||
|
||||
$m->suppressWarning(0);
|
||||
is $m->expandString('$(undef=$(a))'), 'foo', '$(undef=$(a))';
|
||||
is $m->expandString('${undef=${a}}'), 'foo', '${undef=${a}}';
|
||||
is $m->expandString('${undef=$(a)}'), 'foo', '${undef=$(a)}';
|
||||
is $m->expandString('$(undef=${a})'), 'foo', '$(undef=${a})';
|
||||
is $m->expandString('$(a=$(undef))'), 'foo', '$(a=$(undef))';
|
||||
|
||||
$m->putValue('b', 'baz');
|
||||
is $m->expandString('$(b)'), 'baz', '$(b)';
|
||||
is $m->expandString('$(a)'), 'foo', '$(a)';
|
||||
is $m->expandString('$(a)$(b)'), 'foobaz', '$(a)$(b)';
|
||||
is $m->expandString('$(a)/$(b)'), 'foo/baz', '$(a)/$(b)';
|
||||
is $m->expandString('$(a)\$(b)'), 'foo\$(b)', '$(a)\$(b)';
|
||||
is $m->expandString('$(a)$$(b)'), 'foo$baz', '$(a)$$(b)';
|
||||
|
||||
$m->putValue('c', '$(a)');
|
||||
is $m->expandString('$(c)'), 'foo', '$(c)';
|
||||
is $m->expandString('$(undef=$(c))'), 'foo', '$(undef=$(c))';
|
||||
|
||||
$m->putValue('d', 'c');
|
||||
is $m->expandString('$(d)'), 'c', '$(d)';
|
||||
is $m->expandString('$($(d))'), 'foo', '$($(d))';
|
||||
is $m->expandString('$($(b)=$(a))'), 'foo', '$($(b)=$(a))';
|
||||
|
||||
$m->suppressWarning(1);
|
||||
$m->putValue('c', undef);
|
||||
is $m->expandString('$(c)'), '$(c)', '$(c) deleted';
|
||||
|
||||
$m->installMacros('c=fum,d');
|
||||
is $m->expandString('$(c)'), 'fum', 'installMacros, $(c)';
|
||||
|
||||
is $m->expandString('$(d)'), '$(d)', 'installMacros deletion';
|
||||
|
||||
$m->pushScope;
|
||||
is $m->expandString('$(a)'), 'foo', 'pushScope, $(a)';
|
||||
$m->putValue('a', 'grinch');
|
||||
is $m->expandString('$(a)'), 'grinch', 'new $(a) in child';
|
||||
|
||||
$m->putValue('b', undef);
|
||||
is $m->expandString('$(b)'), '$(b)', '$(b) deleted in child';
|
||||
|
||||
$m->popScope;
|
||||
is $m->expandString('$(a)'), 'foo', 'popScope, $(a) restored';
|
||||
is $m->expandString('$(b)'), 'baz', '$(b) restored';
|
||||
|
||||
Reference in New Issue
Block a user