epics/pcas
0
0
Fork 0
Code Issues Pull Requests Projects Wiki Activity

2004-07-12: More implementation, can't remember the details now.

Browse Source
This commit is contained in:
Andrew Johnson
2010-04-08 15:55:49 -05:00
parent 38bd72e67a
commit a1b72626ec
15 changed files with 191 additions and 158 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
src/dbHost/DBD.pm
View File

@@ -13,8 +13,7 @@ use DBD::Variable;
use Carp;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my ($class) = @_;
my $this = {
'DBD::Breaktable' => {},
'DBD::Driver' => {},

17
src/dbHost/DBD/Base.pm
View File

@@ -55,15 +55,15 @@ sub warnContext {
# Input checking
sub unquote {
my ($string) = @_;
$string =~ m/^"(.*)"$/o and $string = $1;
return $string;
sub unquote (\$) {
my ($s) = @_;
$$s =~ s/^"(.*)"$/$1/o;
return $$s;
}
sub identifier {
my $id = unquote(shift);
my $what = shift;
my ($id, $what) = @_;
unquote $id;
confess "$what undefined!" unless defined $id;
$id =~ m/^$RXident$/o or dieContext("Illegal $what '$id'",
"Identifiers are used in C code so must start with a letter, followed",
@@ -75,7 +75,7 @@ sub identifier {
# Output filtering
sub escapeCcomment {
$_ = shift;
($_) = @_;
s/\*\//**/;
return $_;
}
@@ -87,8 +87,7 @@ sub escapeCstring {
# Base class routines for the DBD component objects
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $class = shift;
my $this = {};
bless $this, $class;
return $this->init(@_);

4
src/dbHost/DBD/Breaktable.pm
View File

@@ -14,9 +14,9 @@ sub init {
sub add_point {
my ($this, $raw, $eng) = @_;
confess "Raw value undefined!" unless defined $raw;
$raw = unquote($raw);
confess "Engineering value undefined!" unless defined $eng;
$eng = unquote($eng);
unquote $raw;
unquote $eng;
push @{$this->{POINT_LIST}}, [$raw, $eng];
}

11
src/dbHost/DBD/Device.pm
View File

@@ -18,11 +18,12 @@ my %link_types = (
sub init {
my ($this, $link_type, $dset, $choice) = @_;
unquote $choice;
dieContext("Unknown link type '$link_type', valid types are:",
sort keys %link_types) unless exists $link_types{$link_type};
$this->SUPER::init($dset, "DSET name");
$this->{LINK_TYPE} = $link_type;
$this->{CHOICE} = unquote($choice);
$this->{CHOICE} = $choice;
return $this;
}
@@ -35,10 +36,10 @@ sub choice {
}
sub legal_addr {
my $this = shift;
my $addr = unquote(shift);
my $rx = $link_types{$this->{LINK_TYPE}};
return $addr =~ m/^ $rx $/x;
my ($this, $addr) = @_;
my $rx = $link_types{$this->{LINK_TYPE}};
unquote $addr;
return $addr =~ m/^ $rx $/x;
}
1;

8
src/dbHost/DBD/Menu.pm
View File

@@ -13,7 +13,7 @@ sub init {
sub add_choice {
my ($this, $name, $value) = @_;
$name = identifier($name, "Choice name");
$value = unquote($value, "Choice value");
unquote $value;
foreach $pair ($this->choices) {
dieContext("Duplicate choice name") if ($pair->[0] eq $name);
dieContext("Duplicate choice string") if ($pair->[1] eq $value);
@@ -32,12 +32,12 @@ sub choice {
}
sub legal_choice {
my $this = shift;
my $value = unquote(shift);
my ($this, $value) = @_;
unquote $value;
return exists $this->{CHOICE_INDEX}->{$value};
}
sub toEnum {
sub toDeclaration {
my $this = shift;
my @choices = map {
"\t" . @{$_}[0] . "\t/* " . escapeCcomment(@{$_}[1]) . " */"

59
src/dbHost/DBD/Parser.pm
View File

@@ -26,10 +26,10 @@ our $debug=0;
sub ParseDBD {
my $dbd = shift;
$_ = join '', @_;
$_ = shift;
while (1) {
if (parseCommon()) {}
elsif (m/\G menu \s* \( \s* $string \s* \) \s* \{/oxgc) {
parseCommon();
if (m/\G menu \s* \( \s* $string \s* \) \s* \{/oxgc) {
print "Menu: $1\n" if $debug;
parse_menu($dbd, $1);
}
@@ -75,24 +75,27 @@ sub ParseDBD {
}
sub parseCommon {
# Skip leading whitespace
m/\G \s* /oxgc;
while (1) {
# Skip leading whitespace
m/\G \s* /oxgc;
if (m/\G \#\#!BEGIN\{ ( [^}]* ) \}!\#\# \n/oxgc) {
print "File-Begin: $1\n" if $debug;
pushContext("file '$1'");
if (m/\G \# /oxgc) {
if (m/\G \#!BEGIN\{ ( [^}]* ) \}!\#\# \n/oxgc) {
print "File-Begin: $1\n" if $debug;
pushContext("file '$1'");
}
elsif (m/\G \#!END\{ ( [^}]* ) \}!\#\# \n?/oxgc) {
print "File-End: $1\n" if $debug;
popContext("file '$1'");
}
else {
m/\G (.*) \n/oxgc;
print "Comment: $1\n" if $debug;
}
} else {
return;
}
}
elsif (m/\G \#\#!END\{ ( [^}]* ) \}!\#\# \n/oxgc) {
print "File-End: $1\n" if $debug;
popContext("file '$1'");
}
elsif (m/\G \# (.*) \n/oxgc) {
print "Comment: $1\n" if $debug;
}
else {
return 0;
}
return 1;
}
sub parse_menu {
@@ -100,9 +103,8 @@ sub parse_menu {
pushContext("menu($name)");
my $menu = DBD::Menu->new($name);
while(1) {
if (parseCommon()) {}
elsif (m/\G choice \s* \( \s* $string \s* ,
\s* $string \s* \)/oxgc) {
parseCommon();
if (m/\G choice \s* \( \s* $string \s* , \s* $string \s* \)/oxgc) {
print " Menu-Choice: $1, $2\n" if $debug;
$menu->add_choice($1, $2);
}
@@ -123,8 +125,8 @@ sub parse_breaktable {
pushContext("breaktable($name)");
my $bt = DBD::Breaktable->new($name);
while(1) {
if (parseCommon()) {}
elsif (m/\G point\s* \(\s* $string \s* , \s* $string \s* \)/oxgc) {
parseCommon();
if (m/\G point\s* \(\s* $string \s* , \s* $string \s* \)/oxgc) {
print " Breaktable-Point: $1, $2\n" if $debug;
$bt->add_point($1, $2);
}
@@ -149,9 +151,8 @@ sub parse_recordtype {
pushContext("recordtype($name)");
my $rtyp = DBD::Recordtype->new($name);
while(1) {
if (parseCommon()) {}
elsif (m/\G field \s* \( \s* $string \s* ,
\s* $string \s* \) \s* \{/oxgc) {
parseCommon();
if (m/\G field \s* \( \s* $string \s* , \s* $string \s* \) \s* \{/oxgc) {
print " Recordtype-Field: $1, $2\n" if $debug;
parse_field($rtyp, $1, $2);
}
@@ -172,8 +173,8 @@ sub parse_field {
my $fld = DBD::Recfield->new($name, $field_type);
pushContext("field($name, $field_type)");
while(1) {
if (parseCommon()) {}
elsif (m/\G (\w+) \s* \( \s* $string \s* \)/oxgc) {
parseCommon();
if (m/\G (\w+) \s* \( \s* $string \s* \)/oxgc) {
print " Field-Attribute: $1, $2\n" if $debug;
$fld->add_attribute($1, $2);
}

69
src/dbHost/DBD/Recfield.pm
View File

@@ -24,17 +24,17 @@ our %field_types = (
# The hash value is a regexp that matches all legal values of this attribute
our %field_attrs = (
asl => qr/ASL[01]/,
initial => qr/.*/,
promptgroup => qr/GUI_\w+/,
prompt => qr/.*/,
special => qr/(?:SPC_\w+|\d{3,})/,
pp => qr/(?:YES|NO|TRUE|FALSE)/,
interest => qr/\d+/,
base => qr/(?:DECIMAL|HEX)/,
size => qr/\d+/,
extra => qr/.*/,
menu => qr/$RXident/o
asl => qr/^ASL[01]$/,
initial => qr/^.*$/,
promptgroup => qr/^GUI_\w+$/,
prompt => qr/^.*$/,
special => qr/^(?:SPC_\w+|\d{3,})$/,
pp => qr/^(?:YES|NO|TRUE|FALSE)$/,
interest => qr/^\d+$/,
base => qr/^(?:DECIMAL|HEX)$/,
size => qr/^\d+$/,
extra => qr/^.*$/,
menu => qr/^$RXident$/o
);
sub new {
@@ -47,9 +47,8 @@ sub new {
}
sub init {
my $this = shift;
my $name = shift;
my $type = unquote(shift);
my ($this, $name, $type) = @_;
unquote $type;
$this->SUPER::init($name, "record field name");
dieContext("Illegal field type '$type', valid field types are:",
sort keys %field_types) unless exists $field_types{$type};
@@ -62,15 +61,24 @@ sub dbf_type {
return shift->{DBF_TYPE};
}
sub set_number {
my ($this, $number) = @_;
$this->{NUMBER} = $number;
}
sub number {
return shift->{NUMBER};
}
sub add_attribute {
my $this = shift;
my $attr = shift;
my $value = unquote(shift);
my ($this, $attr, $value) = @_;
unquote $value;
my $match = $field_attrs{$attr};
dieContext("Unknown field attribute '$1', valid attributes are:",
sort keys %field_attrs)
unless exists $field_attrs{$attr};
unless defined $match;
dieContext("Bad value '$value' for field '$attr' attribute")
unless $value =~ m/^ $field_attrs{$attr} $/x;
unless $value =~ m/$match/;
$this->{ATTR_INDEX}->{$attr} = $value;
}
@@ -84,17 +92,13 @@ sub attribute {
}
sub check_valid {
my $this = shift;
my ($this) = @_;
my $name = $this->name;
my $default = $this->attribute("initial");
dieContext("Default value '$default' is invalid for field '$name'")
if (defined($default) and !$this->legal_value($default));
}
# dieContext("Menu name missing for field '$name'")
# if ($this->dbf_type eq "DBF_MENU" and
# !defined($this->attribute("menu")));
sub toDeclaration {
my ($this, $ctype) = @_;
my $name = lc $this->name;
@@ -119,14 +123,14 @@ sub legal_value {
}
sub check_valid {
my $this = shift;
my ($this) = @_;
dieContext("Size missing for DBF_STRING field '$name'")
unless exists $this->attributes->{'size'};
$this->SUPER::check_valid;
}
sub toDeclaration {
my $this = shift;
my ($this) = @_;
my $name = lc $this->name;
my $size = $this->attribute('size');
my $result = "char ${name}[${size}];";
@@ -192,7 +196,7 @@ sub legal_value {
}
sub toDeclaration {
return shift->SUPER::toDeclaration("signed short");
return shift->SUPER::toDeclaration("short");
}
@@ -315,6 +319,13 @@ sub legal_value {
return 1;
}
sub check_valid {
my ($this) = @_;
dieContext("Menu name missing for DBF_MENU field '$name'")
unless defined($this->attribute("menu"));
$this->SUPER::check_valid;
}
sub toDeclaration {
return shift->SUPER::toDeclaration("epicsEnum16");
}
@@ -397,14 +408,14 @@ sub legal_value {
}
sub check_valid {
my $this = shift;
my ($this) = @_;
dieContext("Type information missing for DBF_NOACCESS field '$name'")
unless defined($this->attribute("extra"));
$this->SUPER::check_valid;
}
sub toDeclaration {
my $this = shift;
my ($this) = @_;
my $name = lc $this->name;
my $result = $this->attribute('extra') . ";";
my $prompt = $this->attribute('prompt');

3
src/dbHost/DBD/Recordtype.pm
View File

@@ -21,6 +21,7 @@ sub add_field {
dieContext("Duplicate field name '$field_name'")
if exists $this->{FIELD_INDEX}->{$field_name};
$field->check_valid;
$field->set_number(scalar @{$this->{FIELD_LIST}});
push @{$this->{FIELD_LIST}}, $field;
$this->{FIELD_INDEX}->{$field_name} = $field;
}
@@ -71,7 +72,7 @@ sub device {
return $this->{DEVICE_INDEX}->{$choice};
}
sub toStruct {
sub toDeclaration {
my $this = shift;
my @fields = map {
$_->toDeclaration

2
src/dbHost/DBD/Variable.pm
View File

@@ -7,7 +7,7 @@ my %var_types = ("int" => 1, "double" => 1);
sub init {
my ($this, $name, $type) = @_;
if (defined $type) {
$type = unquote($type);
unquote $type;
} else {
$type = "int";
}

74
src/dbHost/Readfile.pm
View File

@@ -15,14 +15,14 @@ sub slurp {
my @path = @{$Rpath};
print "slurp($FILE):\n" if $debug;
if ($FILE !~ m[/]) {
foreach $dir (@path) {
print " trying $dir/$FILE\n" if $debug;
if (-r "$dir/$FILE") {
$FILE = "$dir/$FILE";
last;
}
}
die "Can't find file '$FILE'\n" unless -r $FILE;
foreach $dir (@path) {
print " trying $dir/$FILE\n" if $debug;
if (-r "$dir/$FILE") {
$FILE = "$dir/$FILE";
last;
}
}
die "Can't find file '$FILE'\n" unless -r $FILE;
}
print " opening $FILE\n" if $debug;
open FILE, "<$FILE" or die "Can't open $FILE: $!\n";
@@ -32,16 +32,13 @@ sub slurp {
push @lines, "##!END{$FILE}!##\n";
close FILE or die "Error closing $FILE: $!\n";
print " read ", scalar @lines, " lines\n" if $debug;
return @lines;
return join '', @lines;
}
sub expandMacros {
my ($macros, @input) = @_;
my @output;
foreach (@input) {
push @output, $macros->expandString($_);
}
return @output;
my ($macros, $input) = @_;
return $input unless $macros;
return $macros->expandString($input);
}
sub splitPath {
@@ -56,37 +53,38 @@ my $RXnam = qr/[a-zA-Z0-9_\-:.[\]<>;]+/o;
my $string = qr/ ( $RXnam | $RXstr ) /ox;
sub unquote {
my ($string) = @_;
$string = $1 if $string =~ m/^"(.*)"$/o;
return $string;
my ($s) = @_;
$s =~ s/^"(.*)"$/$1/o;
return $s;
}
sub Readfile {
my ($file, $macros, $Rpath) = @_;
print "Readfile($file)\n" if $debug;
my @input = &expandMacros($macros, &slurp($file, $Rpath));
my $input = &expandMacros($macros, &slurp($file, $Rpath));
my @input = split /\n/, $input;
my @output;
foreach (@input) {
if (m/^ \s* include \s+ $string /ox) {
$arg = &unquote($1);
print " include $arg\n" if $debug;
push @output, "##! include \"$arg\"\n";
push @output, &Readfile($arg, $macros, $Rpath);
} elsif (m/^ \s* addpath \s+ $string /ox) {
$arg = &unquote($1);
print " addpath $arg\n" if $debug;
push @output, "##! addpath \"$arg\"\n";
push @{$Rpath}, &splitPath($arg);
} elsif (m/^ \s* path \s+ $string /ox) {
$arg = &unquote($1);
print " path $arg\n" if $debug;
push @output, "##! path \"$arg\"\n";
@{$Rpath} = &splitPath($arg);
} else {
push @output, $_;
}
if (m/^ \s* include \s+ $string /ox) {
$arg = &unquote($1);
print " include $arg\n" if $debug;
push @output, "##! include \"$arg\"";
push @output, &Readfile($arg, $macros, $Rpath);
} elsif (m/^ \s* addpath \s+ $string /ox) {
$arg = &unquote($1);
print " addpath $arg\n" if $debug;
push @output, "##! addpath \"$arg\"";
push @{$Rpath}, &splitPath($arg);
} elsif (m/^ \s* path \s+ $string /ox) {
$arg = &unquote($1);
print " path $arg\n" if $debug;
push @output, "##! path \"$arg\"";
@{$Rpath} = &splitPath($arg);
} else {
push @output, $_;
}
}
return @output;
return join "\n", @output;
}
1;

24
src/dbHost/dbToMenuH
View File

@@ -6,16 +6,16 @@ use Getopts;
use macLib;
use Readfile;
getopts('DI@S@o:') or
die "Usage: dbToMenuH [-D] [-I dir] [-S macro=val] [-o menu.h] file.dbd [menu.h]";
my $tool = 'dbToMenuH';
getopts('DI@o:') or
die "Usage: $tool: [-D] [-I dir] [-o menu.h] menu.dbd [menu.h]\n";
my @path = map { split /[:;]/ } @opt_I;
my $macros = macLib->new(@opt_S);
my $dbd = DBD->new();
my $infile = shift @ARGV;
$infile =~ m/\.dbd$/ or
die "Input file '$infile' must have '.dbd' extension\n";
die "$tool: Input file '$infile' must have '.dbd' extension\n";
my $outfile;
if ($opt_o) {
@@ -24,13 +24,15 @@ if ($opt_o) {
$outfile = shift @ARGV;
} else {
($outfile = $infile) =~ s/\.dbd$/.h/;
$outfile =~ s/^.*\///;
}
# Derive a name for the include guard
($guard_name = $outfile) =~ tr/a-zA-Z0-9_/_/cs;
my $guard_name = "INC_$outfile";
$guard_name =~ tr/a-zA-Z0-9_/_/cs;
$guard_name =~ s/(_[hH])?$/_H/;
&ParseDBD($dbd, &Readfile($infile, $macros, \@opt_I));
&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I));
if ($opt_D) {
my %filecount;
@@ -38,14 +40,14 @@ if ($opt_D) {
print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n";
print map { "$_:\n" } @uniqfiles;
} else {
open OUTFILE, ">$outfile" or die "Can't open $outfile: $!\n";
open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n";
print OUTFILE "/* $outfile generated from $infile */\n\n",
"#ifndef INC_${guard_name}\n",
"#define INC_${guard_name}\n\n";
"#ifndef $guard_name\n",
"#define $guard_name\n\n";
my $menus = $dbd->menus;
while (($name, $menu) = each %{$menus}) {
print OUTFILE $menu->toEnum;
print OUTFILE $menu->toDeclaration;
}
print OUTFILE "\n#endif /* INC_${guard_name} */\n";
print OUTFILE "\n#endif /* $guard_name */\n";
close OUTFILE;
}

58
src/dbHost/dbToRecordtypeH
View File

@@ -6,16 +6,16 @@ use Getopts;
use macLib;
use Readfile;
getopts('DI@S@o:') or
die "Usage: dbToRecordtypeH [-D] [-I dir] [-S macro=val] [-o menu.h] file.dbd [menu.h]";
my $tool = 'dbToRecordtypeH';
getopts('DI@o:') or
die "Usage: $tool [-D] [-I dir] [-o xRecord.h] xRecord.dbd [xRecord.h]\n";
my @path = map { split /[:;]/ } @opt_I;
my $macros = macLib->new(@opt_S);
my $dbd = DBD->new();
my $infile = shift @ARGV;
$infile =~ m/\.dbd$/ or
die "Input file '$infile' must have '.dbd' extension\n";
die "$tool: Input file '$infile' must have '.dbd' extension\n";
my $outfile;
if ($opt_o) {
@@ -24,41 +24,65 @@ if ($opt_o) {
$outfile = shift @ARGV;
} else {
($outfile = $infile) =~ s/\.dbd$/.h/;
$outfile =~ s/^.*\///;
$outfile =~ s/dbCommonRecord/dbCommon/;
}
# Derive a name for the include guard
my $guard_name = $outfile;
my $guard_name = "INC_$outfile";
$guard_name =~ tr/a-zA-Z0-9_/_/cs;
$guard_name =~ s/(_[hH])?$/_H/;
&ParseDBD($dbd, &Readfile($infile, $macros, \@opt_I));
&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I));
my $rtypes = $dbd->recordtypes;
die "Input file must contain a single recordtype definition.\n"
die "$tool: Input file must contain a single recordtype definition.\n"
unless (1 == keys %{$rtypes});
if ($opt_D) {
if ($opt_D) { # Output dependencies only, to stdout
my %filecount;
my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n";
print map { "$_:\n" } @uniqfiles;
} else {
open OUTFILE, ">$outfile" or die "Can't open $outfile: $!\n";
open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n";
print OUTFILE "/* $outfile generated from $infile */\n\n",
"#ifndef INC_${guard_name}\n",
"#define INC_${guard_name}\n\n",
"#ifndef $guard_name\n",
"#define $guard_name\n\n",
"#include \"ellLib.h\"\n",
"#include \"epicsMutex.h\"\n",
"#include \"link.h\"\n",
"#include \"epicsTime.h\"\n",
"#include \"epicsTypes.h\"\n\n";
"#include \"epicsTypes.h\"\n",
"#include \"epicsExport.h\"\n\n",
"#ifdef __cplusplus\n",
"extern \"C\" {\n",
"#endif\n\n";
my $menus = $dbd->menus;
while (($name, $menu) = each %{$menus}) {
print OUTFILE $menu->toEnum;
print OUTFILE $menu->toDeclaration;
}
print OUTFILE "\n";
my ($name, $rtyp) = each %{$rtypes};
print OUTFILE $rtyp->toStruct;
print OUTFILE "\n#endif /* INC_${guard_name} */\n";
print OUTFILE "\n" if scalar %{$menus};
my ($rn, $rtyp) = each %{$rtypes};
print OUTFILE $rtyp->toDeclaration;
unless ($rn eq 'dbCommon') {
print OUTFILE "\nenum {\n",
join(",\n", map { "\t${rn}Record$_" } $rtyp->field_names),
"\n};\n\n";
print OUTFILE "#ifdef GEN_SIZE_OFFSET\n",
"static int ${rn}RecordSizeOffset(dbRecordType *pdbRecordType)\n",
"{\n";
# ... FIXME: add size-offset data, etc.
print OUTFILE "}\n\n",
"epicsExportRegistrar(${rn}RecordSizeOffset);\n\n";
}
print OUTFILE "#ifdef __cplusplus\n",
"} /* extern \"C\" */\n",
"#endif\n\n",
"#endif /* $guard_name */\n";
close OUTFILE;
}

8
src/dbHost/test/Base.pl
View File

@@ -1,8 +0,0 @@
#!/usr/bin/perl
use Test::More tests => 2;
use DBD::Base;
is unquote('"x"'), 'x', '"unquote"';
isnt unquote('x""'), 'x', 'unquote""';

4
src/dbHost/test/Recfield.pl
View File

@@ -1,12 +1,14 @@
#!/usr/bin/perl
use Test::More tests => 75;
use Test::More tests => 76;
use DBD::Recfield;
my $fld_string = DBD::Recfield->new('str', 'DBF_STRING');
isa_ok $fld_string, 'DBD::Recfield';
isa_ok $fld_string, 'DBD::Recfield::DBF_STRING';
$fld_string->set_number(0);
is $fld_string->number, 0, 'Field number';
$fld_string->add_attribute("size", "41");
is keys %{$fld_string->attributes}, 1, "Size set";
ok $fld_string->legal_value("Hello, world!"), 'Legal value';

5
src/dbHost/test/Recordtype.pl
View File

@@ -1,6 +1,6 @@
#!/usr/bin/perl
use Test::More tests => 12;
use Test::More tests => 14;
use DBD::Recordtype;
use DBD::Recfield;
@@ -32,6 +32,9 @@ is_deeply \@names, ['NAME', 'DTYP'], 'Field name list';
is $rtyp->field('NAME'), $fld1, 'Field name lookup';
is $fld1->number, 0, 'Field number 0';
is $fld2->number, 1, 'Field number 1';
is $rtyp->devices, 0, 'No devices yet';
my $dev1 = DBD::Device->new('INST_IO', 'testDset', 'test device');