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

2004-07-08: Lots of development work, parser works.

Browse Source
This commit is contained in:
Andrew Johnson
2010-04-08 15:52:36 -05:00
parent 86c12943bc
commit 42367731ef
21 changed files with 517 additions and 577 deletions
Download Patch File Download Diff File Expand all files Collapse all files

74
src/dbHost/DBD.pm
View File

@@ -1,6 +1,6 @@
package DBD;
use DBD::Util;
use DBD::Base;
use DBD::Breaktable;
use DBD::Driver;
use DBD::Menu;
@@ -13,70 +13,70 @@ use DBD::Variable;
use Carp;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $this = {
'DBD::Breaktable' => {},
'DBD::Driver' => {},
'DBD::Function' => {},
'DBD::Menu' => {},
'DBD::Recordtype' => {},
'DBD::Registrar' => {},
'DBD::Variable' => {}
};
bless $this, $class;
return $this;
my $proto = shift;
my $class = ref($proto) || $proto;
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;
foreach (keys %{$this}) {
next unless m/^DBD::/;
$obj_class = $_ and last if $obj->isa($_);
}
confess "Unknown object type"
unless defined $obj_class;
my $obj_name = $obj->name;
dieContext("Duplicate name '$obj_name'")
if exists $this->{$obj_class}->{$obj_name};
$this->{$obj_class}->{$obj_name} = $obj;
my ($this, $obj) = @_;
my $obj_class;
foreach (keys %{$this}) {
next unless m/^DBD::/;
$obj_class = $_ and last if $obj->isa($_);
}
confess "Unknown object type"
unless defined $obj_class;
my $obj_name = $obj->name;
dieContext("Duplicate name '$obj_name'")
if exists $this->{$obj_class}->{$obj_name};
$this->{$obj_class}->{$obj_name} = $obj;
}
sub breaktables {
return %{shift->{'DBD::Breaktable'}};
return shift->{'DBD::Breaktable'};
}
sub drivers {
return %{shift->{'DBD::Driver'}};
return shift->{'DBD::Driver'};
}
sub functions {
return %{shift->{'DBD::Function'}};
return shift->{'DBD::Function'};
}
sub menus {
return %{shift->{'DBD::Menu'}};
return shift->{'DBD::Menu'};
}
sub menu {
my ($this, $menu_name) = @_;
return $this->{'DBD::Menu'}->{$menu_name};
my ($this, $menu_name) = @_;
return $this->{'DBD::Menu'}->{$menu_name};
}
sub recordtypes {
return %{shift->{'DBD::Recordtype'}};
return shift->{'DBD::Recordtype'};
}
sub recordtype {
my ($this, $rtyp_name) = @_;
return $this->{'DBD::Recordtype'}->{$rtyp_name};
my ($this, $rtyp_name) = @_;
return $this->{'DBD::Recordtype'}->{$rtyp_name};
}
sub registrars {
return %{shift->{'DBD::Registrar'}};
return shift->{'DBD::Registrar'};
}
sub variables {
return %{shift->{'DBD::Variable'}};
return shift->{'DBD::Variable'};
}
1;

56
src/dbHost/DBD/Util.pm → src/dbHost/DBD/Base.pm
View File

@@ -1,12 +1,14 @@
package DBD::Util;
# Common utility functions used by the DBD components
package DBD::Base;
use Carp;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(&pushContext &popContext &dieContext &identifier &unquote
$RXident $RXname $RXuint $RXint $RXdex $RXnum $RXdqs $RXsqs $RXstr);
@EXPORT = qw(&pushContext &popContext &dieContext &warnContext
&identifier &unquote &escapeCcomment &escapeCstring
$RXident $RXname $RXuint $RXint $RXdex $RXnum $RXdqs $RXsqs $RXstr);
our $RXident = qr/[a-zA-Z][a-zA-Z0-9_]*/;
@@ -20,9 +22,9 @@ our $RXdqs = qr/" (?: [^"] | \\" )* "/x;
our $RXsqs = qr/' (?: [^'] | \\' )* '/x;
our $RXstr = qr/ ( $RXname | $RXnum | $RXdqs | $RXsqs ) /ox;
our @context;
sub pushContext {
my ($ctxt) = @_;
unshift @context, $ctxt;
@@ -32,8 +34,8 @@ sub popContext {
my ($ctxt) = @_;
my ($pop) = shift @context;
($ctxt ne $pop) and
dieContext("Exiting context \"$ctxt\", found \"$pop\" instead.",
"\tBraces must close in the same file they were opened.");
dieContext("Exiting context \"$ctxt\", found \"$pop\" instead.",
"\tBraces must close in the same file they were opened.");
}
sub dieContext {
@@ -48,6 +50,9 @@ sub warnContext {
print "Context: ", join(' in ', @context), "\n";
}
# Input checking
sub unquote {
my ($string) = @_;
$string =~ m/^"(.*)"$/o and $string = $1;
@@ -59,27 +64,42 @@ sub identifier {
my $what = shift;
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",
"by letters, digits and/or underscore characters only.");
"Identifiers are used in C code so must start with a letter, followed",
"by letters, digits and/or underscore characters only.");
return $id;
}
# Output filtering
sub escapeCcomment {
$_ = shift;
s/\*\//**/;
return $_;
}
sub escapeCstring {
}
# Base class routines for the DBD component objects
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $this = {};
bless $this, $class;
return $this->init(@_);
my $proto = shift;
my $class = ref($proto) || $proto;
my $this = {};
bless $this, $class;
return $this->init(@_);
}
sub init {
my ($this, $name, $what) = @_;
$this->{NAME} = identifier($name, $what);
return $this;
my ($this, $name, $what) = @_;
$this->{NAME} = identifier($name, $what);
return $this;
}
sub name {
return shift->{NAME};
return shift->{NAME};
}
1;

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

@@ -1,6 +1,6 @@
package DBD::Breaktable;
use DBD::Util;
@ISA = qw(DBD::Util);
use DBD::Base;
@ISA = qw(DBD::Base);
use Carp;

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

@@ -1,6 +1,6 @@
package DBD::Device;
use DBD::Util;
@ISA = qw(DBD::Util);
use DBD::Base;
@ISA = qw(DBD::Base);
my %link_types = (
CONSTANT => qr/$RXnum/o,

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

@@ -1,6 +1,6 @@
package DBD::Driver;
use DBD::Util;
@ISA = qw(DBD::Util);
use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
return shift->SUPER::init(shift, "driver entry table name");

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

@@ -1,6 +1,6 @@
package DBD::Function;
use DBD::Util;
@ISA = qw(DBD::Util);
use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
return shift->SUPER::init(shift, "function name");

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

@@ -1,6 +1,6 @@
package DBD::Menu;
use DBD::Util;
@ISA = qw(DBD::Util);
use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
my ($this, $name) = @_;
@@ -37,4 +37,14 @@ sub legal_choice {
return exists $this->{CHOICE_INDEX}->{$value};
}
sub toEnum {
my $this = shift;
my @choices = map {
"\t" . @{$_}[0] . "\t/* " . escapeCcomment(@{$_}[1]) . " */"
} $this->choices;
return "typedef enum {\n" .
join(",\n", @choices) .
"\n} " . $this->name . ";\n";
}
1;

192
src/dbHost/DBD/Parser.pm Normal file
View File

@@ -0,0 +1,192 @@
package DBD::Parser;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(&ParseDBD);
use DBD;
use DBD::Base;
use DBD::Breaktable;
use DBD::Device;
use DBD::Driver;
use DBD::Menu;
use DBD::Recordtype;
use DBD::Recfield;
use DBD::Registrar;
use DBD::Function;
use DBD::Variable;
my $RXnam = qr/[a-zA-Z0-9_\-:.<>;]+/o;
my $RXnum = qr/-? (?: \d+ ) | (?: \d* \. \d+ ) (?: [eE] [-+]? \d+ )?/ox;
my $RXdqs = qr/" (?: [^"] | \\" )* "/ox;
my $RXsqs = qr/' (?: [^'] | \\' )* '/ox;
my $string = qr/ ( $RXnam | $RXnum | $RXdqs | $RXsqs ) /ox;
our $debug=0;
sub ParseDBD {
my $dbd = shift;
$_ = join '', @_;
while (1) {
if (parseCommon()) {}
elsif (m/\G menu \s* \( \s* $string \s* \) \s* \{/oxgc) {
print "Menu: $1\n" if $debug;
parse_menu($dbd, $1);
}
elsif (m/\G driver \s* \( \s* $string \s* \)/oxgc) {
print "Driver: $1\n" if $debug;
$dbd->add(DBD::Driver->new($1));
}
elsif (m/\G registrar \s* \( \s* $string \s* \)/oxgc) {
print "Registrar: $1\n" if $debug;
$dbd->add(DBD::Registrar->new($1));
}
elsif (m/\G function \s* \( \s* $string \s* \)/oxgc) {
print "Function: $1\n" if $debug;
$dbd->add(DBD::Function($1));
}
elsif (m/\G breaktable \s* \( \s* $string \s* \) \s* \{/oxgc) {
print "Breaktable: $1\n" if $debug;
parse_breaktable($dbd, $1);
}
elsif (m/\G recordtype \s* \( \s* $string \s* \) \s* \{/oxgc) {
print "Recordtype: $1\n" if $debug;
parse_recordtype($dbd, $1);
}
elsif (m/\G variable \s* \( \s* $string \s* \)/oxgc) {
print "Variable: $1\n" if $debug;
$dbd->add(DBD::Variable->new($1, 'int'));
}
elsif (m/\G variable \s* \( \s* $string \s* , \s* $string \s* \)/oxgc) {
print "Variable: $1, $2\n" if $debug;
$dbd->add(DBD::Variable->new($1, $2));
}
elsif (m/\G device \s* \( \s* $string \s* , \s* $string \s* ,
\s* $string \s* , \s*$string \s* \)/oxgc) {
print "Device: $1, $2, $3, $4\n" if $debug;
my $rtyp = $dbd->recordtype($1);
dieContext("Unknown record type '$1'") unless defined $rtyp;
$rtyp->add_device(DBD::Device->new($2, $3, $4));
} else {
last unless m/\G (.*) $/moxgc;
dieContext("Syntax error in '$1'");
}
}
}
sub parseCommon {
# Skip leading whitespace
m/\G \s* /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'");
}
elsif (m/\G \# (.*) \n/oxgc) {
print "Comment: $1\n" if $debug;
}
else {
return 0;
}
return 1;
}
sub parse_menu {
my ($dbd, $name) = @_;
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) {
print " Menu-Choice: $1, $2\n" if $debug;
$menu->add_choice($1, $2);
}
elsif (m/\G \}/oxgc) {
print " Menu-End:\n" if $debug;
$dbd->add($menu);
popContext("menu($name)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
sub parse_breaktable {
my ($dbd, $name) = @_;
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) {
print " Breaktable-Point: $1, $2\n" if $debug;
$bt->add_point($1, $2);
}
elsif (m/\G $string \s* (?: , \s*)? $string (?: \s* ,)?/oxgc) {
print " Breaktable-Data: $1, $2\n" if $debug;
$bt->add_point($1, $2);
}
elsif (m/\G \}/oxgc) {
print " Breaktable-End:\n" if $debug;
$dbd->add($bt);
popContext("breaktable($name)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
sub parse_recordtype {
my ($dbd, $name) = @_;
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) {
print " Recordtype-Field: $1, $2\n" if $debug;
parse_field($rtyp, $1, $2);
}
elsif (m/\G \}/oxgc) {
print " Recordtype-End:\n" if $debug;
$dbd->add($rtyp);
popContext("recordtype($name)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
sub parse_field {
my ($rtyp, $name, $field_type) = @_;
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) {
print " Field-Attribute: $1, $2\n" if $debug;
$fld->add_attribute($1, $2);
}
elsif (m/\G \}/oxgc) {
print " Field-End:\n" if $debug;
$rtyp->add_field($fld);
popContext("field($name, $field_type)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
1;

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

@@ -1,96 +1,96 @@
package DBD::Recfield;
use DBD::Util;
@ISA = qw(DBD::Util);
use DBD::Base;
@ISA = qw(DBD::Base);
# The hash value is a regexp that matches all legal values of this field
our %field_types = (
DBF_STRING => qr/.{0,40}/,
DBF_CHAR => $RXint,
DBF_UCHAR => $RXuint,
DBF_SHORT => $RXint,
DBF_USHORT => $RXuint,
DBF_LONG => $RXint,
DBF_ULONG => $RXuint,
DBF_FLOAT => $RXnum,
DBF_DOUBLE => $RXnum,
DBF_ENUM => qr/.*/,
DBF_MENU => qr/.*/,
DBF_DEVICE => qr/.*/,
DBF_INLINK => qr/.*/,
DBF_OUTLINK => qr/.*/,
DBF_FWDLINK => qr/.*/,
DBF_NOACCESS => qr//
DBF_STRING => qr/.{0,40}/,
DBF_CHAR => $RXint,
DBF_UCHAR => $RXuint,
DBF_SHORT => $RXint,
DBF_USHORT => $RXuint,
DBF_LONG => $RXint,
DBF_ULONG => $RXuint,
DBF_FLOAT => $RXnum,
DBF_DOUBLE => $RXnum,
DBF_ENUM => qr/.*/,
DBF_MENU => qr/.*/,
DBF_DEVICE => qr/.*/,
DBF_INLINK => qr/.*/,
DBF_OUTLINK => qr/.*/,
DBF_FWDLINK => qr/.*/,
DBF_NOACCESS => qr//
);
# 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 init {
my $this = shift;
my $name = shift;
my $type = unquote(shift);
$this->SUPER::init($name, "record field name");
exists $field_types{$type} or dieContext("Illegal field type '$type', ".
"valid field types are:", sort keys %field_types);
$this->{DBF_TYPE} = $type;
$this->{ATTR_INDEX} = {};
return $this;
my $this = shift;
my $name = shift;
my $type = unquote(shift);
$this->SUPER::init($name, "record field name");
exists $field_types{$type} or dieContext("Illegal field type '$type', ".
"valid field types are:", sort keys %field_types);
$this->{DBF_TYPE} = $type;
$this->{ATTR_INDEX} = {};
return $this;
}
sub dbf_type {
return shift->{DBF_TYPE};
return shift->{DBF_TYPE};
}
sub add_attribute {
my $this = shift;
my $attr = shift;
my $value = unquote(shift);
dieContext("Unknown field attribute '$1', valid attributes are:",
sort keys %field_attrs)
unless exists $field_attrs{$attr};
dieContext("Bad value '$value' for field '$attr' attribute")
unless $value =~ m/^ $field_attrs{$attr} $/x;
$this->{ATTR_INDEX}->{$attr} = $value;
my $this = shift;
my $attr = shift;
my $value = unquote(shift);
dieContext("Unknown field attribute '$1', valid attributes are:",
sort keys %field_attrs)
unless exists $field_attrs{$attr};
dieContext("Bad value '$value' for field '$attr' attribute")
unless $value =~ m/^ $field_attrs{$attr} $/x;
$this->{ATTR_INDEX}->{$attr} = $value;
}
sub attributes {
return shift->{ATTR_INDEX};
return shift->{ATTR_INDEX};
}
sub attribute {
my ($this, $attr) = @_;
return $this->attributes->{$attr};
my ($this, $attr) = @_;
return $this->attributes->{$attr};
}
sub legal_value {
my ($this, $value) = @_;
my $dbf_type = $this->dbf_type;
return $value =~ m/^ $field_types{$dbf_type} $/x;
my ($this, $value) = @_;
my $dbf_type = $this->dbf_type;
return $value =~ m/^ $field_types{$dbf_type} $/x;
}
sub check_valid {
# Internal validity checks of the field definition
my $this = shift;
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 not defined for field '$name'")
if ($this->dbf_type eq "DBF_MENU"
and !defined($this->attribute("menu")));
# FIXME: Add more checks here?
# Internal validity checks of the field definition
my $this = shift;
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 not defined for field '$name'")
if ($this->dbf_type eq "DBF_MENU"
and !defined($this->attribute("menu")));
# FIXME: Add more checks here?
}
1;

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

@@ -1,6 +1,6 @@
package DBD::Recordtype;
use DBD::Util;
@ISA = qw(DBD::Util);
use DBD::Base;
@ISA = qw(DBD::Base);
use Carp;

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

@@ -1,6 +1,6 @@
package DBD::Registrar;
use DBD::Util;
@ISA = qw(DBD::Util);
use DBD::Base;
@ISA = qw(DBD::Base);
sub init {
return shift->SUPER::init(shift, "registrar function name");

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

@@ -1,6 +1,6 @@
package DBD::Variable;
use DBD::Util;
@ISA = qw(DBD::Util);
use DBD::Base;
@ISA = qw(DBD::Base);
my %var_types = ("int" => 1, "double" => 1);

350
src/dbHost/ReadDBD.pm
View File

@@ -1,350 +0,0 @@
package ReadDBD;
require 5.000;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(%breaktables %devices %drivers %menus %recordtypes
%registrars %functions %variables &ParseDBD);
my $RXnam = qr/[a-zA-Z0-9_\-:.<>;]+/o;
my $RXnum = qr/-? (?: \d+ ) | (?: \d* \. \d+ ) (?: [eE] [-+]? \d+ )?/ox;
my $RXdqs = qr/" (?: [^"] | \\" )* "/ox;
my $RXsqs = qr/' (?: [^'] | \\' )* '/ox;
my $string = qr/ ( $RXnam | $RXnum | $RXdqs | $RXsqs ) /ox;
our $debug=0;
our @context;
our %breaktables; # hash{name} = ref array(array(raw,eng))
our %devices; # hash{rtyp}{name} = array(linktype,dset)
our %drivers; # hash{name} = name
our %menus; # hash{name} = ref array(array(ident,choice))
our %recordtypes; # hash{name} = ref array(array(fname,ref hash{attr}))
our %registrars; # hash{name} = name
our %functions; # hash{name} = name
our %variables; # hash{name} = type
# The hash value is not currently used
my %field_types = (
DBF_STRING => 1,
DBF_CHAR => 1,
DBF_UCHAR => 1,
DBF_SHORT => 1,
DBF_USHORT => 1,
DBF_LONG => 1,
DBF_ULONG => 1,
DBF_FLOAT => 1,
DBF_DOUBLE => 1,
DBF_ENUM => 1,
DBF_MENU => 1,
DBF_DEVICE => 1,
DBF_INLINK => 1,
DBF_OUTLINK => 1,
DBF_FWDLINK => 1,
DBF_NOACCESS => 1
);
# The hash value is a regexp that matches all legal values of this attribute
my %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/[a-zA-Z][a-zA-Z0-9_]*/
);
sub ParseDBD {
$_ = join '', @_;
while (1) {
if (parseCommon()) {}
elsif (m/\G menu \s* \( \s* $string \s* \) \s* \{/oxgc) {
print "Menu: $1\n" if $debug;
parse_menu($1);
}
elsif (m/\G driver \s* \( \s* $string \s* \)/oxgc) {
print "Driver: $1\n" if $debug;
add_driver($1);
}
elsif (m/\G registrar \s* \( \s* $string \s* \)/oxgc) {
print "Registrar: $1\n" if $debug;
add_registrar($1);
}
elsif (m/\G function \s* \( \s* $string \s* \)/oxgc) {
print "Function: $1\n" if $debug;
add_function($1);
}
elsif (m/\G breaktable \s* \( \s* $string \s* \) \s* \{/oxgc) {
print "Breaktable: $1\n" if $debug;
parse_breaktable($1);
}
elsif (m/\G recordtype \s* \( \s* $string \s* \) \s* \{/oxgc) {
print "Recordtype: $1\n" if $debug;
parse_recordtype($1);
}
elsif (m/\G variable \s* \( \s* $string \s* \)/oxgc) {
print "Variable: $1\n" if $debug;
add_variable($1, 'int');
}
elsif (m/\G variable \s* \( \s* $string \s* , \s* $string \s* \)/oxgc) {
print "Variable: $1, $2\n" if $debug;
add_variable($1, $2);
}
elsif (m/\G device \s* \( \s* $string \s* , \s* $string \s* ,
\s* $string \s* , \s*$string \s* \)/oxgc) {
print "Device: $1, $2, $3, $4\n" if $debug;
add_device($1, $2, $3, $4);
} else {
last unless m/\G (.*) $/moxgc;
dieContext("Syntax error in '$1'");
}
}
}
sub parseCommon {
# Skip leading whitespace
m/\G \s* /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'");
}
elsif (m/\G \# (.*) \n/oxgc) {
print "Comment: $1\n" if $debug;
}
else {
return 0;
}
return 1;
}
sub pushContext {
my ($ctxt) = @_;
unshift @context, $ctxt;
}
sub popContext {
my ($ctxt) = @_;
my ($pop) = shift @context;
($ctxt ne $pop) and
dieContext("Exiting context \"$ctxt\", found \"$pop\" instead.",
"\tBraces must close in the same file they were opened.");
}
sub dieContext {
my ($msg) = join "\n\t", @_;
print "$msg\n" if $msg;
die "Context: ", join(' in ', @context), "\n";
}
sub parse_menu {
my ($name) = @_;
pushContext("menu($name)");
my @menu;
while(1) {
if (parseCommon()) {}
elsif (m/\G choice \s* \( \s* $string \s* ,
\s* $string \s* \)/oxgc) {
print " Menu-Choice: $1, $2\n" if $debug;
new_choice(\@menu, $1, $2);
}
elsif (m/\G \}/oxgc) {
print " Menu-End:\n" if $debug;
add_menu($name, @menu);
popContext("menu($name)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
sub new_choice {
my ($Rmenu, $choice_name, $choice_val) = @_;
$choice_name = identifier($choice_name);
$choice_val = unquote($choice_val);
push @{$Rmenu}, [$choice_name, $choice_val];
}
sub identifier {
my ($id) = @_;
$id =~ m/^"(.*)"$/ and $id = $1;
$id !~ m/[a-zA-Z][a-zA-Z0-9_]*/o and dieContext("Illegal identifier '$id'",
"Identifiers are used in C code so must start with a letter, followed",
"by letters, digits and/or underscore characters only.");
return $id;
}
sub unquote {
my ($string) = @_;
$string =~ m/^"(.*)"$/o and $string = $1;
return $string;
}
sub add_menu {
my ($name, @menu) = @_;
$name = identifier($name);
$menus{$name} = \@menu unless exists $menus{$name};
}
sub add_driver {
my ($name) = @_;
$name = identifier($name);
$drivers{$name} = $name unless exists $drivers{$name};
}
sub add_registrar {
my ($reg_name) = @_;
$reg_name = identifier($reg_name);
$registrars{$reg_name} = $reg_name unless exists $registrars{$reg_name};
}
sub add_function {
my ($func_name) = @_;
$func_name = identifier($func_name);
$functions{$func_name} = $func_name unless exists $functions{$func_name};
}
sub parse_breaktable {
my ($name) = @_;
pushContext("breaktable($name)");
my @breaktable;
while(1) {
if (parseCommon()) {}
elsif (m/\G point\s* \(\s* $string \s* , \s* $string \s* \)/oxgc) {
print " Breaktable-Point: $1, $2\n" if $debug;
new_point(\@breaktable, $1, $2);
}
elsif (m/\G $string \s* (?: , \s*)? $string (?: \s* ,)?/oxgc) {
print " Breaktable-Data: $1, $2\n" if $debug;
new_point(\@breaktable, $1, $2);
}
elsif (m/\G \}/oxgc) {
print " Breaktable-End:\n" if $debug;
add_breaktable($name, @breaktable);
popContext("breaktable($name)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
sub new_point {
my ($Rbreaktable, $raw_val, $eng_val) = @_;
push @{$Rbreaktable}, [$raw_val, $eng_val];
}
sub add_breaktable {
my ($name, @brktbl) = @_;
$name = unquote($name);
$breaktables{$name} = \@brktbl
unless exists $breaktables{$name};
}
sub parse_recordtype {
my ($name) = @_;
pushContext("recordtype($name)");
my @rtype;
while(1) {
if (parseCommon()) {}
elsif (m/\G field \s* \( \s* $string \s* ,
\s* $string \s* \) \s* \{/oxgc) {
print " Recordtype-Field: $1, $2\n" if $debug;
parse_field(\@rtype, $1, $2);
}
elsif (m/\G \}/oxgc) {
print " Recordtype-End:\n" if $debug;
add_recordtype($name, @rtype);
popContext("recordtype($name)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
sub parse_field {
my ($Rrtype, $name, $field_type) = @_;
$name = identifier($name);
pushContext("field($name)");
my %field = (type => DBF_type($field_type));
while(1) {
if (parseCommon()) {}
elsif (m/\G (\w+) \s* \( \s* $string \s* \)/oxgc) {
print " Field-Attribute: $1, $2\n" if $debug;
exists $field_attrs{$1} or dieContext("Unknown field attribute ".
"'$1', valid attributes are:", sort keys %field_attrs);
$attr = $1;
$value = unquote($2);
$value =~ m/^$field_attrs{$attr}$/ or dieContext("Bad value '$value' ".
"for field '$attr' attribute");
$field{$attr} = $value;
}
elsif (m/\G \}/oxgc) {
print " Field-End:\n" if $debug;
new_field($Rrtype, $name, %field);
popContext("field($name)");
return;
} else {
m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
dieContext("Syntax error in '$1'");
}
}
}
sub DBF_type {
my ($type) = @_;
$type =~ m/^"(.*)"$/o and $type = $1;
exists $field_types{$type} or dieContext("Illegal field type '$type', ".
"valid field types are:", sort keys %field_types);
return $type;
}
sub new_field {
my ($Rrtype, $name, %field) = @_;
push @{$Rrtype}, [$name, \%field];
}
sub add_recordtype {
my ($name, @rtype) = @_;
$name = identifier($name);
$recordtypes{$name} = \@rtype
unless exists $recordtypes{$name};
}
sub add_variable {
my ($var_name, $var_type) = @_;
$var_name = identifier($var_name);
$var_type = unquote($var_type);
$variables{$var_name} = $var_type
unless exists $variables{$var_name};
}
sub add_device {
my ($record_type, $link_type, $dset, $dev_name) = @_;
$record_type = unquote($record_type);
$link_type = unquote($link_type);
$dset = identifier($dset);
$dev_name = unquote($dev_name);
if (!exists($recordtypes{$record_type})) {
dieContext("Device support for unknown record type '$record_type'",
"device($record_type, $link_type, $dset, \"$dev_name\")");
}
$devices{$record_type}{$dev_name} = [$link_type, $dset]
unless exists $devices{$record_type}{$dev_name};
}
1;

30
src/dbHost/Readfile.pm
View File

@@ -2,6 +2,8 @@ package Readfile;
require 5.000;
require Exporter;
use macLib;
@ISA = qw(Exporter);
@EXPORT = qw(@inputfiles &Readfile);
@@ -16,7 +18,7 @@ sub slurp {
foreach $dir (@path) {
print " trying $dir/$FILE\n" if $debug;
if (-r "$dir/$FILE") {
$FILE = "$dir/$FILE";
$FILE = "$dir/$FILE";
last;
}
}
@@ -33,27 +35,11 @@ sub slurp {
return @lines;
}
sub macval {
my ($macro, $def, $Rmacros) = @_;
if (exists $Rmacros->{$macro}) {
return $Rmacros->{$macro};
} elsif (defined $def) {
return $def;
} else {
warn "Warning: No value for macro \$($macro)\n";
return undef;
}
}
sub expandMacros {
my ($Rmacros, @input) = @_;
my ($macros, @input) = @_;
my @output;
foreach (@input) {
# FIXME: This is wrong, use Text::Balanced, starting from:
# @result = extract_bracketed($_, '{}()\'"', '\s*\$')
s/ \$ \( (\w+) (?: = (.*) )? \) / &macval($1, $2, $Rmacros) /egx
unless /^\s*#/;
push @output, $_;
push @output, $macros->expandString($_);
}
return @output;
}
@@ -76,16 +62,16 @@ sub unquote {
}
sub Readfile {
my ($file, $Rmacros, $Rpath) = @_;
my ($file, $macros, $Rpath) = @_;
print "Readfile($file)\n" if $debug;
my @input = &expandMacros($Rmacros, &slurp($file, $Rpath));
my @input = &expandMacros($macros, &slurp($file, $Rpath));
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, $Rmacros, $Rpath);
push @output, &Readfile($arg, $macros, $Rpath);
} elsif (m/^ \s* addpath \s+ $string /ox) {
$arg = &unquote($1);
print " addpath $arg\n" if $debug;

8
src/dbHost/dbExpand
View File

@@ -6,21 +6,23 @@
use Getopts;
use Readfile;
use macLib;
getopts('DI@S@o:') or
die "Usage: dbExpand [-D] [-I dir] [-S macro=val] [-o out.dbd] in.dbd ...";
my @path = map { split /[:;]/ } @opt_I;
my %macros = map { split /=/ } map { split /,/ } @opt_S;
my @output;
my $macros = macLib->new(@opt_S);
while (@ARGV) {
my @file = &Readfile(shift @ARGV, \%macros, \@opt_I);
my @file = &Readfile(shift @ARGV, $macros, \@opt_I);
# Strip the stuff that Readfile() added:
push @output, grep !/^\#\#!/, @file
}
if ($opt_D) {
if ($opt_D) { # Output dependencies, not the expanded data
my %filecount;
my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
print "$opt_o: ", join(" \\\n ", @uniqfiles), "\n\n";

25
src/dbHost/dbToMenuH
View File

@@ -1,14 +1,18 @@
#!/usr/bin/perl
use ReadDBD;
use DBD;
use DBD::Parser;
use Getopts;
use macLib;
use Readfile;
getopts('DI@S@o:') or
die "Usage: dbToMenu [-D] [-I dir] [-S macro=val] [-o menu.h] file.dbd [menu.h]";
my @path = map { split /[:;]/ } @opt_I;
my %macros = map { split /=/ } map { split /,/ } @opt_S;
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";
@@ -26,7 +30,7 @@ if ($opt_o) {
($guard_name = $outfile) =~ tr/a-zA-Z0-9_/_/cs;
$guard_name =~ s/(_[hH])?$/_H/;
&ParseDBD(&Readfile($infile, \%macros, \@opt_I));
&ParseDBD($dbd, &Readfile($infile, $macros, \@opt_I));
if ($opt_D) {
my %filecount;
@@ -36,17 +40,12 @@ if ($opt_D) {
} else {
open OUTFILE, ">$outfile" or die "Can't open $outfile: $!\n";
print OUTFILE "/* $outfile generated from $infile */\n\n",
"#ifndef INC_${guard_name}\n",
"#define INC_${guard_name}\n\n";
foreach $name (keys %menus) {
print OUTFILE &menuToEnum($menus{$name}, $name);
"#ifndef INC_${guard_name}\n",
"#define INC_${guard_name}\n\n";
my $menus = $dbd->menus;
while (($name, $menu) = each %{$menus}) {
print OUTFILE $menu->toEnum;
}
print OUTFILE "#endif /* INC_${guard_name} */\n";
close OUTFILE;
}
sub menuToEnum {
my ($Rmenu, $name) = @_;
my @choices = map { "\t" . @{$_}[0] } @{$Rmenu};
return "typedef enum {\n" . join(",\n", @choices) . "\n} $name;\n\n";
}

50
src/dbHost/dbdReport
View File

@@ -1,42 +1,52 @@
#!/usr/bin/perl
use ReadDBD;
use DBD;
use DBD::Parser;
use Getopts;
use macLib;
use Readfile;
use Text::Wrap;
#$Readfile::debug = 1;
#$ReadDBD::debug = 1;
#$DBD::Parser::debug = 1;
getopts('I@S@') or die usage();
sub usage() {
"Usage: dbdReport [-I dir] [-S macro=val] file.dbd";
"Usage: dbdReport [-I dir:dir2] [-S macro=val,...] file.dbd ...";
}
my @path = map { split /[:;]/ } @opt_I;
my %macros = map { split /=/ } map { split /,/ } @opt_S;
my $macros = macLib->new(@opt_S);
my $dbd = DBD->new();
&ParseDBD(&Readfile(shift @ARGV, \%macros, \@opt_I));
&ParseDBD($dbd, &Readfile(shift @ARGV, $macros, \@opt_I));
$Text::Wrap::columns = 70;
$Text::Wrap::columns = 75;
print wrap("Menus:\t", "\t", join(', ', sort keys %menus)), "\n"
if %menus;
print wrap("Drivers: ", "\t", join(', ', sort keys %drivers)), "\n"
if %drivers;
print wrap("Variables: ", "\t", join(', ', sort keys %variables)), "\n"
if %variables;
print wrap("Registrars: ", "\t", join(', ', sort keys %registrars)), "\n"
if %registrars;
print wrap("Breaktables: ", "\t", join(', ', sort keys %breaktables)), "\n"
if %breaktables;
my @menus = sort keys %{$dbd->menus};
print wrap("Menus:\t", "\t", join(', ', @menus)), "\n"
if @menus;
my @drivers = sort keys %{$dbd->drivers};
print wrap("Drivers: ", "\t", join(', ', @drivers)), "\n"
if @drivers;
my @variables = sort keys %{$dbd->variables};
print wrap("Variables: ", "\t", join(', ', @variables)), "\n"
if @variables;
my @registrars = sort keys %{$dbd->registrars};
print wrap("Registrars: ", "\t", join(', ', @registrars)), "\n"
if @registrars;
my @breaktables = sort keys %{$dbd->breaktables};
print wrap("Breaktables: ", "\t", join(', ', @breaktables)), "\n"
if @breaktables;
my %recordtypes = %{$dbd->recordtypes};
if (%recordtypes) {
@rtypes = sort keys %recordtypes;
print wrap("Recordtypes: ", "\t", join(', ', @rtypes)), "\n";
foreach (@rtypes) {
print wrap("Devices($_): ", "\t",
join(', ', sort keys %{$devices{$_}})), "\n"
if $devices{$_};
foreach my $rtyp (@rtypes) {
my @devices = $recordtypes{$rtyp}->devices;
print wrap("Devices($rtyp): ", "\t",
join(', ', map {$_->choice} @devices)), "\n"
if @devices;
}
}

65
src/dbHost/macLib.pm
View File

@@ -26,8 +26,8 @@ package macLib;
use Carp;
sub new ($%) {
my ($proto, %values) = @_;
sub new ($@) {
my $proto = shift;
my $class = ref($proto) || $proto;
my $this = {
dirty => 0,
@@ -35,24 +35,10 @@ sub new ($%) {
macros => [{}], # [0] is current scope, [1] is parent etc.
};
bless $this, $class;
$this->installHash(%values);
$this->installList(@_);
return $this;
}
sub suppressWarning($$) {
my ($this, $suppress) = @_;
$this->{noWarn} = $suppress;
}
sub expandString($$) {
my ($this, $src) = @_;
$this->_expand;
my $entry = macLib::entry->new($src, 'string');
my $result = $this->_translate($entry, 0, $src);
return $result unless $entry->{error};
return $this->{noWarn} ? $result : undef;
}
sub putValue ($$$) {
my ($this, $name, $raw) = @_;
if (exists $this->{macros}[0]{$name}) {
@@ -69,24 +55,23 @@ sub putValue ($$$) {
$this->{dirty} = 1;
}
sub installHash ($%) {
my ($this, %values) = @_;
foreach $key (keys %values) {
$this->putValue($key, $values{$key});
sub installList ($@) {
my $this = shift;
while (@_) {
$this->installMacros(shift);
}
}
sub installMacros ($$) {
my $this = shift;
$_ = shift;
my $eos = 0;
until ($eos ||= m/\G \z/xgc) {
until (pos($_) == length($_)) {
m/\G \s* /xgc; # Skip whitespace
if (m/\G ( \w+ ) \s* /xgc) {
my ($name, $val) = ($1);
if (m/\G = \s* /xgc) {
# The value follows, handle quotes and escapes
until ($eos ||= m/\G \z/xgc) {
until (pos($_) == length($_)) {
if (m/\G , /xgc) { last; }
elsif (m/\G ' ( ( [^'] | \\ ' )* ) ' /xgc) { $val .= $1; }
elsif (m/\G " ( ( [^"] | \\ " )* ) " /xgc) { $val .= $1; }
@@ -95,10 +80,10 @@ sub installMacros ($$) {
else { die "How did I get here?"; }
}
$this->putValue($name, $val);
} elsif (m/\G , /xgc or ($eos ||= m/\G \z/xgc)) {
} elsif (m/\G , /xgc or (pos($_) == length($_))) {
$this->putValue($name, undef);
} else {
die "How did I get here?";
warn "How did I get here?";
}
} elsif (m/\G ( .* )/xgc) {
croak "Can't find a macro definition in '$1'";
@@ -110,23 +95,39 @@ sub installMacros ($$) {
sub pushScope ($) {
my ($this) = @_;
push @{$this->{macros}}, {};
unshift @{$this->{macros}}, {};
}
sub popScope ($) {
my ($this) = @_;
pop @{$this->{macros}};
shift @{$this->{macros}};
}
sub suppressWarning($$) {
my ($this, $suppress) = @_;
$this->{noWarn} = $suppress;
}
sub expandString($$) {
my ($this, $src) = @_;
$this->_expand;
my $entry = macLib::entry->new($src, 'string');
my $result = $this->_translate($entry, 0, $src);
return $result unless $entry->{error};
return $this->{noWarn} ? $result : undef;
}
sub reportMacros ($) {
my ($this) = @_;
$this->_expand;
print "Macro report\n";
print "Macro report\n============\n";
foreach my $scope (@{$this->{macros}}) {
foreach my $name (keys %{$scope}) {
my $entry = $scope->{$name};
$entry->report;
}
} continue {
print " -- scope ends --\n";
}
}
@@ -168,7 +169,7 @@ sub _trans ($$$$$) {
if ($$R =~ m/\A [^\$]* \Z/x); # Short-circuit if no macros
my $quote = 0;
my $val;
until ($$R =~ m/\G \z/xgc) {
until (pos($$R) == length($$R)) {
if ($term and ($$R =~ m/\G (?= [$term] ) /xgc)) {
last;
}
@@ -218,7 +219,7 @@ sub _trans ($$$$$) {
} elsif ($$R =~ m/\G \\? ( . ) /xgc) {
$val .= $1;
} else {
die "How did I get here?";
warn "How did I get here? level=$level";
}
} else { # Level 0
if ($$R =~ m/\G \\ ( . ) /xgc) {
@@ -228,7 +229,7 @@ sub _trans ($$$$$) {
} elsif ($$R =~ m/\G ( . ) /xgc) {
$val .= $1;
} else {
die "How did I get here?";
warn "How did I get here? level=$level";
}
}
}

2
src/dbHost/test/Util.pl → src/dbHost/test/Base.pl
View File

@@ -2,7 +2,7 @@
use Test::More tests => 2;
use DBD::Util;
use DBD::Base;
is unquote('"x"'), 'x', '"unquote"';
isnt unquote('x""'), 'x', 'unquote""';

3
src/dbHost/test/Menu.pl
View File

@@ -1,6 +1,6 @@
#!/usr/bin/perl
use Test::More tests => 13;
use Test::More tests => 14;
use DBD::Menu;
@@ -21,3 +21,4 @@ is_deeply $menu->choice(1), ['ch2', 'Choice 2'], 'Second choice found';
ok !$menu->legal_choice('Choice 3'), 'Third choice not legal';
is_deeply $menu->choice(2), undef, 'Third choice undefined';
is $menu->toEnum, "typedef enum {\n\tch1\t/* Choice 1 */,\n\tch2\t/* Choice 2 */\n} test;\n", 'enum';

69
src/dbHost/test/macLib.pl Normal file
View File

@@ -0,0 +1,69 @@
#!/usr/bin/perl
use Test::More tests => 34;
use macLib;
use Data::Dumper;
my $m = macLib->new;
isa_ok $m, 'macLib';
is $m->expandString(''), '', 'Empty string';
is $m->expandString('$(undef)'), undef, 'Warning $(undef)';
$m->suppressWarning(1);
is $m->expandString('$(undef)'), '$(undef)', 'Suppressed $(undef)';
$m->putValue('a', 'foo');
is $m->expandString('$(a)'), 'foo', '$(a)';
is $m->expandString('${a}'), 'foo', '${a}';
is $m->expandString('$(a=bar)'), 'foo', '$(a=bar)';
is $m->expandString('${a=bar}'), 'foo', '${a=bar}';
is $m->expandString('$(undef)'), '$(undef)', '$(undef) again';
is $m->expandString('${undef}'), '$(undef)', '${undef} again';
$m->suppressWarning(0);
is $m->expandString('$(undef=$(a))'), 'foo', '$(undef=$(a))';
is $m->expandString('${undef=${a}}'), 'foo', '${undef=${a}}';
is $m->expandString('${undef=$(a)}'), 'foo', '${undef=$(a)}';
is $m->expandString('$(undef=${a})'), 'foo', '$(undef=${a})';
is $m->expandString('$(a=$(undef))'), 'foo', '$(a=$(undef))';
$m->putValue('b', 'baz');
is $m->expandString('$(b)'), 'baz', '$(b)';
is $m->expandString('$(a)'), 'foo', '$(a)';
is $m->expandString('$(a)$(b)'), 'foobaz', '$(a)$(b)';
is $m->expandString('$(a)/$(b)'), 'foo/baz', '$(a)/$(b)';
is $m->expandString('$(a)\$(b)'), 'foo\$(b)', '$(a)\$(b)';
is $m->expandString('$(a)$$(b)'), 'foo$baz', '$(a)$$(b)';
$m->putValue('c', '$(a)');
is $m->expandString('$(c)'), 'foo', '$(c)';
is $m->expandString('$(undef=$(c))'), 'foo', '$(undef=$(c))';
$m->putValue('d', 'c');
is $m->expandString('$(d)'), 'c', '$(d)';
is $m->expandString('$($(d))'), 'foo', '$($(d))';
is $m->expandString('$($(b)=$(a))'), 'foo', '$($(b)=$(a))';
$m->suppressWarning(1);
$m->putValue('c', undef);
is $m->expandString('$(c)'), '$(c)', '$(c) deleted';
$m->installMacros('c=fum,d');
is $m->expandString('$(c)'), 'fum', 'installMacros, $(c)';
is $m->expandString('$(d)'), '$(d)', 'installMacros deletion';
$m->pushScope;
is $m->expandString('$(a)'), 'foo', 'pushScope, $(a)';
$m->putValue('a', 'grinch');
is $m->expandString('$(a)'), 'grinch', 'new $(a) in child';
$m->putValue('b', undef);
is $m->expandString('$(b)'), '$(b)', '$(b) deleted in child';
$m->popScope;
is $m->expandString('$(a)'), 'foo', 'popScope, $(a) restored';
is $m->expandString('$(b)'), 'baz', '$(b) restored';