From 680e05c2c2b51f4b5ce1d083767c241a416d1d6c Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 15:48:50 -0500 Subject: [PATCH] 2004-06-23: Fixed various things, added Recordtype and global DBD object tests. --- src/dbHost/DBD.pm | 89 ++++++++++++++++++++++------------- src/dbHost/DBD/Breaktable.pm | 8 ++-- src/dbHost/DBD/Menu.pm | 8 ++-- src/dbHost/DBD/Recfield.pm | 6 +-- src/dbHost/DBD/Recordtype.pm | 23 +++++---- src/dbHost/Readfile.pm | 9 +++- src/dbHost/test/DBD.pl | 57 ++++++++++++++++++++++ src/dbHost/test/Recordtype.pl | 45 ++++++++++++++++++ 8 files changed, 188 insertions(+), 57 deletions(-) create mode 100644 src/dbHost/test/DBD.pl create mode 100644 src/dbHost/test/Recordtype.pl diff --git a/src/dbHost/DBD.pm b/src/dbHost/DBD.pm index 1cf82cc8a..f63541cc1 100644 --- a/src/dbHost/DBD.pm +++ b/src/dbHost/DBD.pm @@ -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; diff --git a/src/dbHost/DBD/Breaktable.pm b/src/dbHost/DBD/Breaktable.pm index b36067aa1..12ae449b5 100644 --- a/src/dbHost/DBD/Breaktable.pm +++ b/src/dbHost/DBD/Breaktable.pm @@ -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; diff --git a/src/dbHost/DBD/Menu.pm b/src/dbHost/DBD/Menu.pm index 8ae4291ae..fe602dcbf 100644 --- a/src/dbHost/DBD/Menu.pm +++ b/src/dbHost/DBD/Menu.pm @@ -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 { diff --git a/src/dbHost/DBD/Recfield.pm b/src/dbHost/DBD/Recfield.pm index 81c0e410d..16eba16e5 100644 --- a/src/dbHost/DBD/Recfield.pm +++ b/src/dbHost/DBD/Recfield.pm @@ -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 { diff --git a/src/dbHost/DBD/Recordtype.pm b/src/dbHost/DBD/Recordtype.pm index c505395e6..8160966a2 100644 --- a/src/dbHost/DBD/Recordtype.pm +++ b/src/dbHost/DBD/Recordtype.pm @@ -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 { diff --git a/src/dbHost/Readfile.pm b/src/dbHost/Readfile.pm index 755c030b6..9b5efdf04 100644 --- a/src/dbHost/Readfile.pm +++ b/src/dbHost/Readfile.pm @@ -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; diff --git a/src/dbHost/test/DBD.pl b/src/dbHost/test/DBD.pl new file mode 100644 index 000000000..fb76f95d9 --- /dev/null +++ b/src/dbHost/test/DBD.pl @@ -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'; + diff --git a/src/dbHost/test/Recordtype.pl b/src/dbHost/test/Recordtype.pl new file mode 100644 index 000000000..d4d47d6c6 --- /dev/null +++ b/src/dbHost/test/Recordtype.pl @@ -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'; +