2004-06-04: Sync laptop => CVS
This commit is contained in:
Andrew Johnson
@@ -0,0 +1,57 @@
|
||||
package DBD;
|
||||
|
||||
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 new {
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $this = {
|
||||
BREAKTABLES => {},
|
||||
DEVICES => {},
|
||||
DRIVERS => {},
|
||||
MENUS => {},
|
||||
RECORDTYPES => {},
|
||||
REGISTRARS => {},
|
||||
FUNCTIONS => {},
|
||||
VARIABLES => {}
|
||||
};
|
||||
bless $this, $class;
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub add_breaktable {
|
||||
}
|
||||
|
||||
sub add_driver {
|
||||
}
|
||||
|
||||
sub add_menu {
|
||||
}
|
||||
|
||||
sub add_recordtype {
|
||||
}
|
||||
|
||||
sub add_registrar {
|
||||
}
|
||||
|
||||
sub add_function {
|
||||
}
|
||||
|
||||
sub add_variable {
|
||||
my ($this, $obj) = @_;
|
||||
confess "Not a DBD::Variable" unless $obj->isa('DBD::Variable');
|
||||
my $obj_name = $obj->name;
|
||||
dieContext("Duplicate variable '$obj_name'")
|
||||
if exists $this->{VARIABLES}->{$obj_name};
|
||||
$this->{VARIABLES}->{$obj_name} = $obj;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,32 @@
|
||||
package DBD::Breaktable;
|
||||
use DBD::Util;
|
||||
@ISA = qw(DBD::Util);
|
||||
|
||||
use Carp;
|
||||
|
||||
sub init {
|
||||
my ($this, $name) = @_;
|
||||
$this->SUPER::init($name, "breakpoint table name");
|
||||
$this->{POINTS} = [];
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub add_point {
|
||||
my ($this, $raw, $eng) = @_;
|
||||
confess "Raw value undefined!" unless defined $raw;
|
||||
$raw = unquote($raw);
|
||||
confess "Engineering value undefined!" unless defined $eng;
|
||||
$eng = unquote($eng);
|
||||
push @{$this->{POINTS}}, [$raw, $eng];
|
||||
}
|
||||
|
||||
sub points {
|
||||
return @{shift->{POINTS}};
|
||||
}
|
||||
|
||||
sub point {
|
||||
my ($this, $idx) = @_;
|
||||
return $this->{POINTS}[$idx];
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,44 @@
|
||||
package DBD::Device;
|
||||
use DBD::Util;
|
||||
@ISA = qw(DBD::Util);
|
||||
|
||||
my %link_types = (
|
||||
CONSTANT => qr/$RXnum/o,
|
||||
PV_LINK => qr/$RXname \s+ [.NPCAMS ]*/ox,
|
||||
VME_IO => qr/\# (?: \s* [CS] \s* $RXdex)* \s* (?: @ .*)?/ox,
|
||||
CAMAC_IO => qr/\# (?: \s* [BCNAF] \s* $RXdex)* \s* (?: @ .*)?/ox,
|
||||
RF_IO => qr/\# (?: \s* [RMDE] \s* $RXdex)*/ox,
|
||||
AB_IO => qr/\# (?: \s* [LACS] \s* $RXdex)* \s* (?: @ .*)?/ox,
|
||||
GPIB_IO => qr/\# (?: \s* [LA] \s* $RXdex)* \s* (?: @ .*)?/ox,
|
||||
BITBUS_IO => qr/\# (?: \s* [LNPS] \s* $RXdex)* \s* (?: @ .*)?/ox,
|
||||
BBGPIB_IO => qr/\# (?: \s* [LBG] \s* $RXdex)* \s* (?: @ .*)?/ox,
|
||||
VXI_IO => qr/\# (?: \s* [VCS] \s* $RXdex)* \s* (?: @ .*)?/ox,
|
||||
INST_IO => qr/@.*/
|
||||
);
|
||||
|
||||
sub init {
|
||||
my ($this, $link_type, $dset, $choice) = @_;
|
||||
dieContext("Unknown link type '$link_type', valid types are:",
|
||||
sort keys %link_types) unless exists $link_types{$link_type};
|
||||
$this->SUPER::init($dset, "DSET name");
|
||||
$this->{LINK_TYPE} = $link_type;
|
||||
$this->{CHOICE} = unquote($choice);
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub link_type {
|
||||
return shift->{LINK_TYPE};
|
||||
}
|
||||
|
||||
sub choice {
|
||||
return shift->{CHOICE};
|
||||
}
|
||||
|
||||
sub legal_addr {
|
||||
my $this = shift;
|
||||
my $addr = unquote(shift);
|
||||
my $rx = $link_types{$this->{LINK_TYPE}};
|
||||
return $addr =~ m/^ $rx $/x;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,9 @@
|
||||
package DBD::Driver;
|
||||
use DBD::Util;
|
||||
@ISA = qw(DBD::Util);
|
||||
|
||||
sub init {
|
||||
return shift->SUPER::init(shift, "driver entry table name");
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,9 @@
|
||||
package DBD::Function;
|
||||
@ISA = qw(DBD::Util);
|
||||
|
||||
sub init {
|
||||
return shift->SUPER::init(shift, "function name");
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -0,0 +1,40 @@
|
||||
package DBD::Menu;
|
||||
use DBD::Util;
|
||||
@ISA = qw(DBD::Util);
|
||||
|
||||
sub init {
|
||||
my ($this, $name) = @_;
|
||||
$this->SUPER::init($name, "menu name");
|
||||
$this->{CHOICES} = [];
|
||||
$this->{CHOICE_INDEX} = {};
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub add_choice {
|
||||
my ($this, $name, $value) = @_;
|
||||
$name = identifier($name, "Choice name");
|
||||
$value = unquote($value, "Choice 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->{CHOICES}}, [$name, $value];
|
||||
$this->{CHOICE_INDEX}->{$value} = $name;
|
||||
}
|
||||
|
||||
sub choices {
|
||||
return @{shift->{CHOICES}};
|
||||
}
|
||||
|
||||
sub choice {
|
||||
my ($this, $idx) = @_;
|
||||
return $this->{CHOICES}[$idx];
|
||||
}
|
||||
|
||||
sub legal_choice {
|
||||
my $this = shift;
|
||||
my $value = unquote(shift);
|
||||
return exists $this->{CHOICE_INDEX}->{$value};
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,96 @@
|
||||
package DBD::Recfield;
|
||||
use DBD::Util;
|
||||
@ISA = qw(DBD::Util);
|
||||
|
||||
# The hash value is a regexp that matches all legal values of this field
|
||||
our %field_types = (
|
||||
DBF_STRING => qr/.{0,40}/,
|
||||
DBF_CHAR => $RXint,
|
||||
DBF_UCHAR => $RXuint,
|
||||
DBF_SHORT => $RXint,
|
||||
DBF_USHORT => $RXuint,
|
||||
DBF_LONG => $RXint,
|
||||
DBF_ULONG => $RXuint,
|
||||
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/(?:YES|NO|TRUE|FALSE)/,
|
||||
interest => qr/\d+/,
|
||||
base => qr/(?:DECIMAL|HEX)/,
|
||||
size => qr/\d+/,
|
||||
extra => qr/.*/,
|
||||
menu => qr/$RXident/o
|
||||
);
|
||||
|
||||
sub init {
|
||||
my $this = shift;
|
||||
my $name = shift;
|
||||
my $type = unquote(shift);
|
||||
$this->SUPER::init($name, "record field name");
|
||||
exists $field_types{$type} or dieContext("Illegal field type '$type', ".
|
||||
"valid field types are:", sort keys %field_types);
|
||||
$this->{DBF_TYPE} = $type;
|
||||
$this->{ATTRIBUTES} = {};
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub dbf_type {
|
||||
return shift->{DBF_TYPE};
|
||||
}
|
||||
|
||||
sub add_attribute {
|
||||
my $this = shift;
|
||||
my $attr = shift;
|
||||
my $value = unquote(shift);
|
||||
dieContext("Unknown field attribute '$1', valid attributes are:",
|
||||
sort keys %field_attrs)
|
||||
unless exists $field_attrs{$attr};
|
||||
dieContext("Bad value '$value' for field '$attr' attribute")
|
||||
unless $value =~ m/^ $field_attrs{$attr} $/x;
|
||||
$this->{ATTRIBUTES}->{$attr} = $value;
|
||||
}
|
||||
|
||||
sub attributes {
|
||||
return shift->{ATTRIBUTES};
|
||||
}
|
||||
|
||||
sub attribute {
|
||||
my ($this, $attr) = @_;
|
||||
return $this->attributes->{$attr};
|
||||
}
|
||||
|
||||
sub legal_value {
|
||||
my ($this, $value) = @_;
|
||||
my $dbf_type = $this->dbf_type;
|
||||
return $value =~ m/^ $field_types{$dbf_type} $/x;
|
||||
}
|
||||
|
||||
sub check_valid {
|
||||
# Internal validity checks of the field definition
|
||||
my $this = shift;
|
||||
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));
|
||||
dieContext("Menu name not defined for field '$name'")
|
||||
if ($this->dbf_type eq "DBF_MENU"
|
||||
and !defined($this->attribute("menu")));
|
||||
# FIXME: Add more checks here?
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,75 @@
|
||||
package DBD::Recordtype;
|
||||
use DBD::Util;
|
||||
@ISA = qw(DBD::Util);
|
||||
|
||||
use Carp;
|
||||
|
||||
sub init {
|
||||
my $this = shift;
|
||||
$this->SUPER::init(@_);
|
||||
$this->{FIELDS} = []; # Ordered list
|
||||
$this->{FIELD_INDEX} = {}; # Indexed by name
|
||||
$this->{DEVICES} = []; # Ordered list
|
||||
$this->{DEVICE_INDEX} = {}; # Indexed by choice
|
||||
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;
|
||||
push $this->{FIELDS}, $field;
|
||||
$this->{FIELD_INDEX}->{$field_name} = $field;
|
||||
}
|
||||
|
||||
sub fields {
|
||||
return shift->{FIELDS};
|
||||
}
|
||||
|
||||
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) = @_;
|
||||
return $this->{FIELD_INDEX}->{$field};
|
||||
}
|
||||
|
||||
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;
|
||||
}
|
||||
$device->check_valid;
|
||||
push $this->{DEVICES}, $device;
|
||||
$this->{DEVICE_INDEX}->{$choice} = $device;
|
||||
}
|
||||
|
||||
sub devices {
|
||||
my $this = shift;
|
||||
return $this->{DEVICES};
|
||||
}
|
||||
|
||||
sub device {
|
||||
my ($this, $choice) = @_;
|
||||
return $this->{DEVICE_INDEX}->{$choice};
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,10 @@
|
||||
package DBD::Registrar;
|
||||
@ISA = qw(DBD::Util);
|
||||
|
||||
sub init {
|
||||
return shift->SUPER::init(shift, "registrar function name");
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
@@ -0,0 +1,85 @@
|
||||
package DBD::Util;
|
||||
|
||||
use Carp;
|
||||
|
||||
require Exporter;
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(&pushContext &popContext &dieContext &identifier &unquote
|
||||
$RXident $RXname $RXuint $RXint $RXdex $RXnum $RXdqs $RXsqs $RXstr);
|
||||
|
||||
|
||||
our $RXident = qr/[a-zA-Z][a-zA-Z0-9_]*/;
|
||||
our $RXname = qr/[a-zA-Z0-9_\-:.<>;]+/;
|
||||
our $RXhex = qr/ (?: 0 [xX] [0-9A-Fa-f]+ ) /x;
|
||||
our $RXuint = qr/ \d+ /x;
|
||||
our $RXint = qr/ -? $RXuint /ox;
|
||||
our $RXdex = qr/ ( $RXhex | $RXuint ) /x;
|
||||
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";
|
||||
}
|
||||
|
||||
sub unquote {
|
||||
my ($string) = @_;
|
||||
$string =~ m/^"(.*)"$/o and $string = $1;
|
||||
return $string;
|
||||
}
|
||||
|
||||
sub identifier {
|
||||
my $id = unquote(shift);
|
||||
my $what = shift;
|
||||
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.");
|
||||
return $id;
|
||||
}
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
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,27 @@
|
||||
package DBD::Variable;
|
||||
use DBD::Util;
|
||||
@ISA = qw(DBD::Util);
|
||||
|
||||
my %var_types = ("int" => 1, "double" => 1);
|
||||
|
||||
sub init {
|
||||
my ($this, $name, $type) = @_;
|
||||
if (defined $type) {
|
||||
$type = unquote($type);
|
||||
} else {
|
||||
$type = "int";
|
||||
}
|
||||
exists $var_types{$type} or
|
||||
dieContext("Unknown variable type '$type', valid types are:",
|
||||
sort keys %var_types);
|
||||
$this->SUPER::init($name, "variable name");
|
||||
$this->{VAR_TYPE} = $type;
|
||||
return $this;
|
||||
}
|
||||
|
||||
sub var_type {
|
||||
my $this = shift;
|
||||
return $this->{VAR_TYPE};
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user