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

Permit but check duplicate DBD entries

Browse Source 
Record types cannot be duplicated however.
DBD sub-objects now have a ->what method for their description.
This also adds a method to look up a breaktable by name.
This commit is contained in:
Andrew Johnson
2012-08-22 16:54:54 -05:00
parent 786a01b59c
commit f29e995103
13 changed files with 134 additions and 80 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/tools/DBD.pm
+15 -10
View File
@@ -29,22 +29,27 @@ sub new {
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_class = ref $obj;
confess "DBD::add: Unknown DBD object type '$obj_class'"
unless $obj_class =~ m/^DBD::/
and exists $this->{$obj_class};
my $obj_name = $obj->name;
dieContext("Duplicate name '$obj_name'")
if exists $this->{$obj_class}->{$obj_name};
$this->{$obj_class}->{$obj_name} = $obj;
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 breaktables {
return shift->{'DBD::Breaktable'};
}
sub breaktable {
my ($this, $name) = @_;
return $this->{'DBD::Breaktable'}->{$name};
}
sub drivers {
return shift->{'DBD::Driver'};
src/tools/DBD/Base.pm
+19 -7
View File
@@ -34,19 +34,19 @@ sub pushContext {
sub popContext {
my ($ctxt) = @_;
my ($pop) = shift @context;
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.");
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", @_;
my $msg = join "\n\t", @_;
die "$msg\nContext: ", join(' in ', @context), "\n";
}
sub warnContext {
my ($msg) = join "\n\t", @_;
my $msg = join "\n\t", @_;
print STDERR "$msg\nContext: ", join(' in ', @context), "\n";
}
@@ -77,7 +77,8 @@ sub is_reserved {
sub identifier {
my ($id, $what) = @_;
unquote $id;
confess "$what undefined!" unless defined $id;
confess "DBD::Base::identifier: $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.");
@@ -114,7 +115,8 @@ sub new {
sub init {
my ($this, $name, $what) = @_;
$this->{NAME} = identifier($name, $what);
$this->{NAME} = identifier($name, "$what name");
$this->{WHAT} = $what;
return $this;
}
@@ -122,4 +124,14 @@ sub name {
return shift->{NAME};
}
sub what {
return shift->{WHAT};
}
sub equals {
my ($a, $b) = @_;
return $a->{NAME} eq $b->{NAME}
&& $a->{WHAT} eq $b->{WHAT};
}
1;
src/tools/DBD/Breaktable.pm
+20 -11
View File
@@ -5,23 +5,25 @@ use DBD::Base;
use Carp;
sub init {
my ($this, $name) = @_;
$this->SUPER::init($name, "breakpoint table name");
$this->{POINT_LIST} = [];
return $this;
my ($this, $name) = @_;
$this->SUPER::init($name, "breakpoint table");
$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];
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;
unquote $raw;
unquote $eng;
push @{$this->{POINT_LIST}}, [$raw, $eng];
}
sub points {
return @{shift->{POINT_LIST}};
return @{shift->{POINT_LIST}};
}
sub point {
@@ -29,4 +31,11 @@ sub point {
return $this->{POINT_LIST}[$idx];
}
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;
src/tools/DBD/Device.pm
+32 -25
View File
@@ -3,43 +3,50 @@ 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/@.*/
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;
my ($this, $link_type, $dset, $choice) = @_;
unquote $choice;
dieContext("Unknown link type '$link_type', valid types are:",
sort keys %link_types) unless exists $link_types{$link_type};
$this->SUPER::init($dset, "device support (dset)");
$this->{LINK_TYPE} = $link_type;
$this->{CHOICE} = $choice;
return $this;
}
sub link_type {
return shift->{LINK_TYPE};
return shift->{LINK_TYPE};
}
sub choice {
return shift->{CHOICE};
return shift->{CHOICE};
}
sub legal_addr {
my ($this, $addr) = @_;
my $rx = $link_types{$this->{LINK_TYPE}};
unquote $addr;
return $addr =~ m/^ $rx $/x;
my ($this, $addr) = @_;
my $rx = $link_types{$this->{LINK_TYPE}};
unquote $addr;
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;
src/tools/DBD/Driver.pm
+1 -1
View File
@@ -3,7 +3,7 @@ use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
return shift->SUPER::init(shift, "driver entry table name");
return shift->SUPER::init(shift, "driver support (drvet)");
}
1;
src/tools/DBD/Function.pm
+1 -2
View File
@@ -3,8 +3,7 @@ use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
return shift->SUPER::init(shift, "function name");
return shift->SUPER::init(shift, "function");
}
1;
src/tools/DBD/Menu.pm
+8 -1
View File
@@ -4,7 +4,7 @@ use DBD::Base;
sub init {
my ($this, $name) = @_;
$this->SUPER::init($name, "menu name");
$this->SUPER::init($name, "menu");
$this->{CHOICE_LIST} = [];
$this->{CHOICE_INDEX} = {};
return $this;
@@ -39,6 +39,13 @@ sub legal_choice {
return exists $this->{CHOICE_INDEX}->{$value};
}
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;
src/tools/DBD/Output.pm
+4 -1
View File
@@ -48,7 +48,10 @@ sub OutputRecordtypes {
printf $out " field(%s, %s) {\n",
$field->name, $field->dbf_type;
while (my ($attr, $val) = each %{$field->attributes}) {
$val = "\"$val\"" if $val !~ m/^$RXname$/ox;
$val = "\"$val\""
if $val !~ m/^$RXname$/ox
|| $attr eq 'prompt'
|| $attr eq 'initial';
printf $out " %s(%s)\n", $attr, $val;
}
print $out " }\n";
src/tools/DBD/Parser.pm
+3 -2
View File
@@ -49,7 +49,7 @@ sub ParseDBD {
}
elsif (m/\G variable \s* \( \s* $RXstr \s* \)/oxgc) {
print "Variable: $1\n" if $debug;
$dbd->add(DBD::Variable->new($1, 'int'));
$dbd->add(DBD::Variable->new($1));
}
elsif (m/\G variable \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) {
print "Variable: $1, $2\n" if $debug;
@@ -59,7 +59,8 @@ sub ParseDBD {
\s* $RXstr \s* , \s*$RXstr \s* \)/oxgc) {
print "Device: $1, $2, $3, $4\n" if $debug;
my $rtyp = $dbd->recordtype($1);
dieContext("Unknown record type '$1'") unless defined $rtyp;
dieContext("Unknown record type '$1'")
unless defined $rtyp;
$rtyp->add_device(DBD::Device->new($2, $3, $4));
} else {
last unless m/\G (.*) $/moxgc;
src/tools/DBD/Recfield.pm
+6 -1
View File
@@ -3,6 +3,7 @@ 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,
@@ -49,7 +50,7 @@ sub new {
sub init {
my ($this, $name, $type) = @_;
unquote $type;
$this->SUPER::init($name, "record field name");
$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;
@@ -91,6 +92,10 @@ sub attribute {
return $this->attributes->{$attr};
}
sub equals {
dieContext("Record field objects are not comparable");
}
sub check_valid {
my ($this) = @_;
my $name = $this->name;
src/tools/DBD/Recordtype.pm
+17 -15
View File
@@ -5,8 +5,8 @@ use DBD::Base;
use Carp;
sub init {
my $this = shift;
$this->SUPER::init(@_);
my ($this, $name) = @_;
$this->SUPER::init($name, "record type");
$this->{FIELD_LIST} = [];
$this->{FIELD_INDEX} = {};
$this->{DEVICE_LIST} = [];
@@ -17,7 +17,8 @@ sub init {
sub add_field {
my ($this, $field) = @_;
confess "Not a DBD::Recfield" unless $field->isa('DBD::Recfield');
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};
@@ -32,12 +33,7 @@ sub fields {
}
sub field_names { # In their original order...
my $this = shift;
my @names = ();
foreach ($this->fields) {
push @names, $_->name
}
return @names;
return map {$_->name} @{shift->{FIELD_LIST}};
}
sub field {
@@ -47,17 +43,18 @@ sub field {
sub add_device {
my ($this, $device) = @_;
confess "Not a DBD::Device" unless $device->isa('DBD::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}) {
my @warning = ("Duplicate device type '$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);
if $old->link_type ne $device->link_type;
push @warning, "DSETs differ"
if ($old->name ne $device->name);
warnContext(@warning);
return;
if $old->name ne $device->name;
dieContext(@warning);
}
push @{$this->{DEVICE_LIST}}, $device;
$this->{DEVICE_INDEX}->{$choice} = $device;
@@ -85,6 +82,11 @@ sub toCdefs {
return join("\n", shift->cdefs) . "\n\n";
}
sub equals {
my ($a, $b) = @_;
dieContext("Duplicate definition of record type '$a->{NAME}'");
}
sub toDeclaration {
my $this = shift;
my @fields = map {
src/tools/DBD/Registrar.pm
+1 -3
View File
@@ -3,9 +3,7 @@ use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
return shift->SUPER::init(shift, "registrar function name");
return shift->SUPER::init(shift, "registrar function");
}
1;
src/tools/DBD/Variable.pm
+7 -1
View File
@@ -18,7 +18,7 @@ sub init {
exists $valid_types{$type} or
dieContext("Unknown variable type '$type', valid types are:",
sort keys %valid_types);
$this->SUPER::init($name, "variable name");
$this->SUPER::init($name, "variable");
$this->{VAR_TYPE} = $type;
return $this;
}
@@ -33,4 +33,10 @@ sub iocshArg_type {
return $valid_types{$this->{VAR_TYPE}};
}
sub equals {
my ($a, $b) = @_;
return $a->SUPER::equals($b)
&& $a->{VAR_TYPE} eq $b->{VAR_TYPE};
}
1;