146 lines
2.9 KiB
Perl
146 lines
2.9 KiB
Perl
######################################################################
|
|
# SPDX-License-Identifier: EPICS
|
|
# EPICS BASE is distributed subject to a Software License Agreement
|
|
# found in file LICENSE that is included with this distribution.
|
|
######################################################################
|
|
|
|
package DBD;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use DBD::Base;
|
|
use DBD::Breaktable;
|
|
use DBD::Driver;
|
|
use DBD::Link;
|
|
use DBD::Menu;
|
|
use DBD::Recordtype;
|
|
use DBD::Recfield;
|
|
use DBD::Record;
|
|
use DBD::Registrar;
|
|
use DBD::Function;
|
|
use DBD::Variable;
|
|
|
|
use Carp;
|
|
|
|
sub new {
|
|
my ($class) = @_;
|
|
my $this = {
|
|
'DBD::Breaktable' => {},
|
|
'DBD::Driver' => {},
|
|
'DBD::Link' => {},
|
|
'DBD::Function' => {},
|
|
'DBD::Menu' => {},
|
|
'DBD::Recordtype' => {},
|
|
'DBD::Record' => {},
|
|
'DBD::Registrar' => {},
|
|
'DBD::Variable' => {},
|
|
'RECORDS' => [],
|
|
'COMMENTS' => [],
|
|
'POD' => []
|
|
};
|
|
bless $this, $class;
|
|
return $this;
|
|
}
|
|
|
|
sub add {
|
|
my ($this, $obj, $obj_name) = @_;
|
|
my $obj_class = ref $obj;
|
|
confess "DBD::add: Unknown DBD object type '$obj_class'"
|
|
unless $obj_class =~ m/^DBD::/
|
|
and exists $this->{$obj_class};
|
|
$obj_name = $obj->name unless defined $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 add_comment {
|
|
my $this = shift;
|
|
push @{$this->{COMMENTS}}, @_;
|
|
}
|
|
|
|
sub comments {
|
|
return @{shift->{COMMENTS}};
|
|
}
|
|
|
|
sub add_pod {
|
|
my $this = shift;
|
|
push @{$this->{POD}}, @_;
|
|
}
|
|
|
|
sub pod {
|
|
return @{shift->{POD}};
|
|
}
|
|
|
|
sub breaktables {
|
|
return shift->{'DBD::Breaktable'};
|
|
}
|
|
sub breaktable {
|
|
my ($this, $name) = @_;
|
|
return $this->{'DBD::Breaktable'}->{$name};
|
|
}
|
|
|
|
sub drivers {
|
|
return shift->{'DBD::Driver'};
|
|
}
|
|
|
|
sub links {
|
|
return shift->{'DBD::Link'};
|
|
}
|
|
|
|
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 records {
|
|
return shift->{'DBD::Record'};
|
|
}
|
|
sub record {
|
|
my ($this, $record_name) = @_;
|
|
return $this->{'DBD::Record'}->{$record_name};
|
|
}
|
|
|
|
sub add_record {
|
|
my ($this, $record_name) = @_;
|
|
push @{$this->{RECORDS}}, $record_name;
|
|
}
|
|
sub record_names {
|
|
return @{shift->{RECORDS}};
|
|
}
|
|
sub sort_records {
|
|
my $this = shift;
|
|
my @sorted = sort @{$this->{RECORDS}};
|
|
$this->{RECORDS} = \@sorted;
|
|
}
|
|
|
|
sub registrars {
|
|
return shift->{'DBD::Registrar'};
|
|
}
|
|
|
|
sub variables {
|
|
return shift->{'DBD::Variable'};
|
|
}
|
|
|
|
1;
|