diff --git a/src/dbHost/DBD.pm b/src/dbHost/DBD.pm index f63541cc1..400d39003 100644 --- a/src/dbHost/DBD.pm +++ b/src/dbHost/DBD.pm @@ -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; diff --git a/src/dbHost/DBD/Util.pm b/src/dbHost/DBD/Base.pm similarity index 56% rename from src/dbHost/DBD/Util.pm rename to src/dbHost/DBD/Base.pm index 54ee6e435..8e703aabb 100644 --- a/src/dbHost/DBD/Util.pm +++ b/src/dbHost/DBD/Base.pm @@ -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; diff --git a/src/dbHost/DBD/Breaktable.pm b/src/dbHost/DBD/Breaktable.pm index 12ae449b5..3db134347 100644 --- a/src/dbHost/DBD/Breaktable.pm +++ b/src/dbHost/DBD/Breaktable.pm @@ -1,6 +1,6 @@ package DBD::Breaktable; -use DBD::Util; -@ISA = qw(DBD::Util); +use DBD::Base; +@ISA = qw(DBD::Base); use Carp; diff --git a/src/dbHost/DBD/Device.pm b/src/dbHost/DBD/Device.pm index c59d20f9f..1b7972450 100644 --- a/src/dbHost/DBD/Device.pm +++ b/src/dbHost/DBD/Device.pm @@ -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, diff --git a/src/dbHost/DBD/Driver.pm b/src/dbHost/DBD/Driver.pm index 8cee4d05e..7eedcdf8d 100644 --- a/src/dbHost/DBD/Driver.pm +++ b/src/dbHost/DBD/Driver.pm @@ -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"); diff --git a/src/dbHost/DBD/Function.pm b/src/dbHost/DBD/Function.pm index f90062d6c..51e17d8aa 100644 --- a/src/dbHost/DBD/Function.pm +++ b/src/dbHost/DBD/Function.pm @@ -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"); diff --git a/src/dbHost/DBD/Menu.pm b/src/dbHost/DBD/Menu.pm index fe602dcbf..3ab7ccc38 100644 --- a/src/dbHost/DBD/Menu.pm +++ b/src/dbHost/DBD/Menu.pm @@ -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; diff --git a/src/dbHost/DBD/Parser.pm b/src/dbHost/DBD/Parser.pm new file mode 100644 index 000000000..14f456ef9 --- /dev/null +++ b/src/dbHost/DBD/Parser.pm @@ -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; diff --git a/src/dbHost/DBD/Recfield.pm b/src/dbHost/DBD/Recfield.pm index 16eba16e5..3cb0c94c1 100644 --- a/src/dbHost/DBD/Recfield.pm +++ b/src/dbHost/DBD/Recfield.pm @@ -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; diff --git a/src/dbHost/DBD/Recordtype.pm b/src/dbHost/DBD/Recordtype.pm index 8160966a2..2c673d5a6 100644 --- a/src/dbHost/DBD/Recordtype.pm +++ b/src/dbHost/DBD/Recordtype.pm @@ -1,6 +1,6 @@ package DBD::Recordtype; -use DBD::Util; -@ISA = qw(DBD::Util); +use DBD::Base; +@ISA = qw(DBD::Base); use Carp; diff --git a/src/dbHost/DBD/Registrar.pm b/src/dbHost/DBD/Registrar.pm index d3c120311..b4692c596 100644 --- a/src/dbHost/DBD/Registrar.pm +++ b/src/dbHost/DBD/Registrar.pm @@ -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"); diff --git a/src/dbHost/DBD/Variable.pm b/src/dbHost/DBD/Variable.pm index 2791bb4ed..c0b78a2ff 100644 --- a/src/dbHost/DBD/Variable.pm +++ b/src/dbHost/DBD/Variable.pm @@ -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); diff --git a/src/dbHost/ReadDBD.pm b/src/dbHost/ReadDBD.pm deleted file mode 100644 index 46cdd68c6..000000000 --- a/src/dbHost/ReadDBD.pm +++ /dev/null @@ -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; diff --git a/src/dbHost/Readfile.pm b/src/dbHost/Readfile.pm index 9b5efdf04..dda27e49d 100644 --- a/src/dbHost/Readfile.pm +++ b/src/dbHost/Readfile.pm @@ -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; diff --git a/src/dbHost/dbExpand b/src/dbHost/dbExpand index 1f9dd1337..d70a594a1 100755 --- a/src/dbHost/dbExpand +++ b/src/dbHost/dbExpand @@ -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"; diff --git a/src/dbHost/dbToMenuH b/src/dbHost/dbToMenuH index e99929fa9..7ccce2c35 100755 --- a/src/dbHost/dbToMenuH +++ b/src/dbHost/dbToMenuH @@ -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"; -} diff --git a/src/dbHost/dbdReport b/src/dbHost/dbdReport index 6c94e7212..7b0060c98 100755 --- a/src/dbHost/dbdReport +++ b/src/dbHost/dbdReport @@ -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; } } diff --git a/src/dbHost/macLib.pm b/src/dbHost/macLib.pm index b5f3a2294..5bd7dd379 100644 --- a/src/dbHost/macLib.pm +++ b/src/dbHost/macLib.pm @@ -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"; } } } diff --git a/src/dbHost/test/Util.pl b/src/dbHost/test/Base.pl similarity index 89% rename from src/dbHost/test/Util.pl rename to src/dbHost/test/Base.pl index 7de8c887e..fd600be51 100644 --- a/src/dbHost/test/Util.pl +++ b/src/dbHost/test/Base.pl @@ -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""'; diff --git a/src/dbHost/test/Menu.pl b/src/dbHost/test/Menu.pl index 635c9a6ec..a2ea7f764 100644 --- a/src/dbHost/test/Menu.pl +++ b/src/dbHost/test/Menu.pl @@ -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'; diff --git a/src/dbHost/test/macLib.pl b/src/dbHost/test/macLib.pl new file mode 100644 index 000000000..db0a3122b --- /dev/null +++ b/src/dbHost/test/macLib.pl @@ -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'; +