3c99391d93
In some cases the license-identification header was missing, so I added that as well. Replaced the remaining headers that specifically identified "Versions 3.13.7 and higher". Makefiles and the build system were deliberately excluded.
130 lines
3.1 KiB
Perl
130 lines
3.1 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::Record;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use DBD::Base;
|
|
|
|
our @ISA = qw(DBD::Base);
|
|
|
|
use Carp;
|
|
|
|
our ($macrosOk);
|
|
my $warned;
|
|
|
|
sub init {
|
|
my ($this, $type, $name) = @_;
|
|
confess "DBD::Record::init: Not a DBD::Recordtype"
|
|
unless $type->isa('DBD::Recordtype');
|
|
$this->SUPER::init($name, "record");
|
|
$this->{RECORD_TYPE} = $type;
|
|
$this->{ALIASES} = [];
|
|
$this->{RECFIELD_LIST} = [];
|
|
$this->{FIELD_INDEX} = {};
|
|
$this->{INFO_LIST} = [];
|
|
$this->{INFO_ITEMS} = {};
|
|
$this->{COMMENTS} = [];
|
|
$this->{POD} = [];
|
|
return $this;
|
|
}
|
|
|
|
# Override, record names are not as strict as recordtype and menu names
|
|
sub identifier {
|
|
my ($this, $id, $what) = @_;
|
|
confess "DBD::Record::identifier: $what undefined!"
|
|
unless defined $id;
|
|
if ($macrosOk) {
|
|
# FIXME - Check name with macro
|
|
}
|
|
elsif ($id !~ m/^$RXname$/) {
|
|
my @message;
|
|
push @message, "A $what should contain only letters, digits and these",
|
|
"special characters: _ - : . [ ] < > ;" unless $warned++;
|
|
warnContext("Deprecated $what '$id'", @message);
|
|
}
|
|
return $id;
|
|
}
|
|
|
|
sub recordtype {
|
|
return shift->{RECORD_TYPE};
|
|
}
|
|
|
|
sub add_alias {
|
|
my ($this, $alias) = @_;
|
|
push @{$this->{ALIASES}}, $this->identifier($alias, "alias name");
|
|
}
|
|
|
|
sub aliases {
|
|
return @{shift->{ALIASES}};
|
|
}
|
|
|
|
sub put_field {
|
|
my ($this, $field_name, $value) = @_;
|
|
my $recfield = $this->{RECORD_TYPE}->field($field_name);
|
|
dieContext("No field named '$field_name'")
|
|
unless defined $recfield;
|
|
dieContext("Can't set $field_name to '$value'")
|
|
unless $recfield->legal_value($value);
|
|
push @{$this->{RECFIELD_LIST}}, $recfield
|
|
unless exists $this->{FIELD_INDEX}->{$field_name};
|
|
$this->{FIELD_INDEX}->{$field_name} = $value;
|
|
}
|
|
|
|
sub recfields {
|
|
return @{shift->{RECFIELD_LIST}};
|
|
}
|
|
|
|
sub field_names { # In their original order...
|
|
return map {$_->name} @{shift->{RECFIELD_LIST}};
|
|
}
|
|
|
|
sub get_field {
|
|
my ($this, $field_name) = @_;
|
|
return $this->{FIELD_INDEX}->{$field_name}
|
|
if exists $this->{FIELD_INDEX}->{$field_name};
|
|
my $recfield = $this->{RECORD_TYPE}->field($field_name);
|
|
return $recfield->attribute("initial");
|
|
}
|
|
|
|
sub add_info {
|
|
my ($this, $info_name, $value) = @_;
|
|
push @{$this->{INFO_LIST}}, $info_name
|
|
unless exists $this->{INFO_ITEMS}->{$info_name};
|
|
$this->{INFO_ITEMS}->{$info_name} = $value;
|
|
}
|
|
|
|
sub info_names {
|
|
return @{shift->{INFO_LIST}};
|
|
}
|
|
|
|
sub info_value {
|
|
my ($this, $info_name) = @_;
|
|
return $this->{INFO_ITEMS}->{$info_name};
|
|
}
|
|
|
|
sub add_comment {
|
|
my ($this, $comment) = @_;
|
|
push @{$this->{COMMENTS}}, $comment;
|
|
}
|
|
|
|
sub comments {
|
|
return @{shift->{COMMENTS}};
|
|
}
|
|
|
|
sub add_pod {
|
|
my $this = shift;
|
|
push @{$this->{POD}}, @_;
|
|
}
|
|
|
|
sub pod {
|
|
return @{shift->{POD}};
|
|
}
|
|
|
|
1;
|