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

2004-06-23: Fixed various things, added Recordtype and global DBD object tests.

Browse Source
This commit is contained in:
Andrew Johnson
2010-04-08 15:48:50 -05:00
parent b20cf681ae
commit 680e05c2c2
8 changed files with 188 additions and 57 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/dbHost/DBD.pm
+57 -32
View File
@@ -1,7 +1,7 @@
package DBD;
use DBD::Util;
use DBD::Breaktable;
use DBD::Device;
use DBD::Driver;
use DBD::Menu;
use DBD::Recordtype;
@@ -10,48 +10,73 @@ use DBD::Registrar;
use DBD::Function;
use DBD::Variable;
use Carp;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $this = {
BREAKTABLES => {},
DEVICES => {},
DRIVERS => {},
MENUS => {},
RECORDTYPES => {},
REGISTRARS => {},
FUNCTIONS => {},
VARIABLES => {}
'DBD::Breaktable' => {},
'DBD::Driver' => {},
'DBD::Function' => {},
'DBD::Menu' => {},
'DBD::Recordtype' => {},
'DBD::Registrar' => {},
'DBD::Variable' => {}
};
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 {
sub add {
my ($this, $obj) = @_;
confess "Not a DBD::Variable" unless $obj->isa('DBD::Variable');
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 variable '$obj_name'")
if exists $this->{VARIABLES}->{$obj_name};
$this->{VARIABLES}->{$obj_name} = $obj;
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;
src/dbHost/DBD/Breaktable.pm
+4 -4
View File
@@ -7,7 +7,7 @@ use Carp;
sub init {
my ($this, $name) = @_;
$this->SUPER::init($name, "breakpoint table name");
$this->{POINTS} = [];
$this->{POINT_LIST} = [];
return $this;
}
@@ -17,16 +17,16 @@ sub add_point {
$raw = unquote($raw);
confess "Engineering value undefined!" unless defined $eng;
$eng = unquote($eng);
push @{$this->{POINTS}}, [$raw, $eng];
push @{$this->{POINT_LIST}}, [$raw, $eng];
}
sub points {
return @{shift->{POINTS}};
return @{shift->{POINT_LIST}};
}
sub point {
my ($this, $idx) = @_;
return $this->{POINTS}[$idx];
return $this->{POINT_LIST}[$idx];
}
1;
src/dbHost/DBD/Menu.pm
+4 -4
View File
@@ -5,7 +5,7 @@ use DBD::Util;
sub init {
my ($this, $name) = @_;
$this->SUPER::init($name, "menu name");
$this->{CHOICES} = [];
$this->{CHOICE_LIST} = [];
$this->{CHOICE_INDEX} = {};
return $this;
}
@@ -18,17 +18,17 @@ sub add_choice {
dieContext("Duplicate choice name") if ($pair->[0] eq $name);
dieContext("Duplicate choice string") if ($pair->[1] eq $value);
}
push @{$this->{CHOICES}}, [$name, $value];
push @{$this->{CHOICE_LIST}}, [$name, $value];
$this->{CHOICE_INDEX}->{$value} = $name;
}
sub choices {
return @{shift->{CHOICES}};
return @{shift->{CHOICE_LIST}};
}
sub choice {
my ($this, $idx) = @_;
return $this->{CHOICES}[$idx];
return $this->{CHOICE_LIST}[$idx];
}
sub legal_choice {
src/dbHost/DBD/Recfield.pm
+3 -3
View File
@@ -45,7 +45,7 @@ sub init {
exists $field_types{$type} or dieContext("Illegal field type '$type', ".
"valid field types are:", sort keys %field_types);
$this->{DBF_TYPE} = $type;
$this->{ATTRIBUTES} = {};
$this->{ATTR_INDEX} = {};
return $this;
}
@@ -62,11 +62,11 @@ sub add_attribute {
unless exists $field_attrs{$attr};
dieContext("Bad value '$value' for field '$attr' attribute")
unless $value =~ m/^ $field_attrs{$attr} $/x;
$this->{ATTRIBUTES}->{$attr} = $value;
$this->{ATTR_INDEX}->{$attr} = $value;
}
sub attributes {
return shift->{ATTRIBUTES};
return shift->{ATTR_INDEX};
}
sub attribute {
src/dbHost/DBD/Recordtype.pm
+11 -12
View File
@@ -7,10 +7,10 @@ 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
$this->{FIELD_LIST} = [];
$this->{FIELD_INDEX} = {};
$this->{DEVICE_LIST} = [];
$this->{DEVICE_INDEX} = {};
return $this;
}
@@ -21,12 +21,12 @@ sub add_field {
dieContext("Duplicate field name '$field_name'")
if exists $this->{FIELD_INDEX}->{$field_name};
$field->check_valid;
push $this->{FIELDS}, $field;
push @{$this->{FIELD_LIST}}, $field;
$this->{FIELD_INDEX}->{$field_name} = $field;
}
sub fields {
return shift->{FIELDS};
return @{shift->{FIELD_LIST}};
}
sub field_names { # In their original order...
@@ -39,8 +39,8 @@ sub field_names { # In their original order...
}
sub field {
my ($this, $field) = @_;
return $this->{FIELD_INDEX}->{$field};
my ($this, $field_name) = @_;
return $this->{FIELD_INDEX}->{$field_name};
}
sub add_device {
@@ -54,17 +54,16 @@ sub add_device {
if ($old->link_type ne $device->link_type);
push @warning, "DSETs differ"
if ($old->name ne $device->name);
warnContext @warning;
warnContext(@warning);
return;
}
$device->check_valid;
push $this->{DEVICES}, $device;
push @{$this->{DEVICE_LIST}}, $device;
$this->{DEVICE_INDEX}->{$choice} = $device;
}
sub devices {
my $this = shift;
return $this->{DEVICES};
return @{$this->{DEVICE_LIST}};
}
sub device {
src/dbHost/Readfile.pm
+7 -2
View File
@@ -34,9 +34,11 @@ sub slurp {
}
sub macval {
my ($macro, $Rmacros) = @_;
my ($macro, $def, $Rmacros) = @_;
if (exists $Rmacros->{$macro}) {
return $Rmacros->{$macro};
} elsif (defined $def) {
return $def;
} else {
warn "Warning: No value for macro \$($macro)\n";
return undef;
@@ -47,7 +49,10 @@ sub expandMacros {
my ($Rmacros, @input) = @_;
my @output;
foreach (@input) {
s/\$\((\w+)\)/&macval($1, $Rmacros)/eg unless /^\s*#/;
# FIXME: This is wrong, use Text::Balanced, starting from:
# @result = extract_bracketed($_, '{}()\'"', '\s*\$')
s/ \$ \( (\w+) (?: = (.*) )? \) / &macval($1, $2, $Rmacros) /egx
unless /^\s*#/;
push @output, $_;
}
return @output;
src/dbHost/test/DBD.pl
+57
View File
@@ -0,0 +1,57 @@
#!/usr/bin/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 $reg = DBD::Breaktable->new('Brighton');
$dbd->add($reg);
my %regs = $dbd->breaktables;
is_deeply \%regs, {Brighton => $reg}, 'Added breaktable';
is keys %{$dbd->drivers}, 0, 'No drivers yet';
my $reg = DBD::Driver->new('Danforth');
$dbd->add($reg);
my %regs = $dbd->drivers;
is_deeply \%regs, {Danforth => $reg}, 'Added driver';
is keys %{$dbd->functions}, 0, 'No functions yet';
my $reg = DBD::Function->new('Frank');
$dbd->add($reg);
my %regs = $dbd->functions;
is_deeply \%regs, {Frank => $reg}, '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';
src/dbHost/test/Recordtype.pl
+45
View File
@@ -0,0 +1,45 @@
#!/usr/bin/perl
use Test::More tests => 12;
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 $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';