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.
87 lines
1.7 KiB
Perl
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;
|