Files
epics-base/src/tools/DBD.pm
Andrew Johnson f29e995103 Permit but check duplicate DBD entries
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.
2012-08-22 16:54:54 -05:00

87 lines
1.7 KiB
Perl

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 = 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;
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'};
}
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;