diff --git a/src/tools/DBD.pm b/src/tools/DBD.pm index 3189588c3..3a2a85ee4 100644 --- a/src/tools/DBD.pm +++ b/src/tools/DBD.pm @@ -1,11 +1,15 @@ package DBD; +use strict; +use warnings; + use DBD::Base; use DBD::Breaktable; use DBD::Driver; use DBD::Menu; use DBD::Recordtype; use DBD::Recfield; +use DBD::Record; use DBD::Registrar; use DBD::Function; use DBD::Variable; @@ -20,6 +24,7 @@ sub new { 'DBD::Function' => {}, 'DBD::Menu' => {}, 'DBD::Recordtype' => {}, + 'DBD::Record' => {}, 'DBD::Registrar' => {}, 'DBD::Variable' => {}, 'COMMENTS' => [], @@ -30,12 +35,12 @@ sub new { } sub add { - my ($this, $obj) = @_; + my ($this, $obj, $obj_name) = @_; my $obj_class = ref $obj; confess "DBD::add: Unknown DBD object type '$obj_class'" unless $obj_class =~ m/^DBD::/ and exists $this->{$obj_class}; - my $obj_name = $obj->name; + $obj_name = $obj->name unless defined $obj_name; if (exists $this->{$obj_class}->{$obj_name}) { return if $obj->equals($this->{$obj_class}->{$obj_name}); dieContext("A different $obj->{WHAT} named '$obj_name' already exists"); @@ -95,6 +100,14 @@ sub recordtype { return $this->{'DBD::Recordtype'}->{$rtyp_name}; } +sub records { + return shift->{'DBD::Record'}; +} +sub record { + my ($this, $record_name) = @_; + return $this->{'DBD::Record'}->{$record_name}; +} + sub registrars { return shift->{'DBD::Registrar'}; } diff --git a/src/tools/DBD/Base.pm b/src/tools/DBD/Base.pm index b0388d725..e258e650a 100644 --- a/src/tools/DBD/Base.pm +++ b/src/tools/DBD/Base.pm @@ -2,17 +2,21 @@ package DBD::Base; +use strict; +use warnings; + use Carp; require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(&pushContext &popContext &dieContext &warnContext &is_reserved - &identifier &unquote &escapeCcomment &escapeCstring $RXident $RXname - $RXuint $RXint $RXhex $RXoct $RXuintx $RXintx $RXnum $RXdqs $RXsqs $RXstr); +our @ISA = qw(Exporter); + +our @EXPORT = qw(&pushContext &popContext &dieContext &warnContext &is_reserved + &escapeCcomment &escapeCstring $RXident $RXname $RXuint $RXint $RXhex $RXoct + $RXuintx $RXintx $RXnum $RXdqs $RXsqs $RXstr); our $RXident = qr/ [a-zA-Z] [a-zA-Z0-9_]* /x; -our $RXname = qr/ [a-zA-Z0-9_\-:.<>;]+ /x; +our $RXname = qr/ [a-zA-Z0-9_\-:.\[\]<>;]+ /x; our $RXhex = qr/ (?: 0 [xX] [0-9A-Fa-f]+ ) /x; our $RXoct = qr/ 0 [0-7]* /x; our $RXuint = qr/ \d+ /x; @@ -20,8 +24,8 @@ our $RXint = qr/ -? $RXuint /ox; our $RXuintx = qr/ ( $RXhex | $RXoct | $RXuint ) /ox; our $RXintx = qr/ ( $RXhex | $RXoct | $RXint ) /ox; our $RXnum = qr/ -? (?: \d+ | \d* \. \d+ ) (?: [eE] [-+]? \d+ )? /x; -our $RXdqs = qr/" (?: [^"] | \\" )* " /x; -our $RXsqs = qr/' (?: [^'] | \\' )* ' /x; +our $RXdqs = qr/ " (?: [^"] | \\" )* " /x; +our $RXsqs = qr/ ' (?: [^'] | \\' )* ' /x; our $RXstr = qr/ ( $RXname | $RXnum | $RXdqs | $RXsqs ) /ox; our @context; @@ -51,14 +55,6 @@ sub warnContext { } -# Input checking - -sub unquote (\$) { - my ($s) = @_; - $$s =~ s/^"(.*)"$/$1/o; - return $$s; -} - # Reserved words from C++ and the DB/DBD file parser my %reserved = map { $_ => undef } qw(and and_eq asm auto bitand bitor bool break case catch char class compl const const_cast continue default delete @@ -75,8 +71,7 @@ sub is_reserved { } sub identifier { - my ($id, $what) = @_; - unquote $id; + my ($this, $id, $what) = @_; confess "DBD::Base::identifier: $what undefined!" unless defined $id; $id =~ m/^$RXident$/o or dieContext("Illegal $what '$id'", @@ -115,7 +110,7 @@ sub new { sub init { my ($this, $name, $what) = @_; - $this->{NAME} = identifier($name, "$what name"); + $this->{NAME} = $this->identifier($name, "$what name"); $this->{WHAT} = $what; return $this; } diff --git a/src/tools/DBD/Breaktable.pm b/src/tools/DBD/Breaktable.pm index eb7bea6c9..c14ab8d65 100644 --- a/src/tools/DBD/Breaktable.pm +++ b/src/tools/DBD/Breaktable.pm @@ -9,6 +9,7 @@ sub init { $this->SUPER::init($name, "breakpoint table"); $this->{POINT_LIST} = []; $this->{COMMENTS} = []; + $this->{POD} = []; return $this; } @@ -18,8 +19,6 @@ sub add_point { unless defined $raw; confess "DBD::Breaktable::add_point: Engineering value undefined!" unless defined $eng; - unquote $raw; - unquote $eng; push @{$this->{POINT_LIST}}, [$raw, $eng]; } @@ -41,6 +40,15 @@ sub comments { return @{shift->{COMMENTS}}; } +sub add_pod { + my $this = shift; + push @{$this->{POD}}, @_; +} + +sub pod { + return @{shift->{POD}}; +} + sub equals { my ($a, $b) = @_; return $a->SUPER::equals($b) diff --git a/src/tools/DBD/Device.pm b/src/tools/DBD/Device.pm index 72072e545..5d13a9655 100644 --- a/src/tools/DBD/Device.pm +++ b/src/tools/DBD/Device.pm @@ -18,7 +18,6 @@ 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, "device support (dset)"); @@ -38,7 +37,6 @@ sub choice { sub legal_addr { my ($this, $addr) = @_; my $rx = $link_types{$this->{LINK_TYPE}}; - unquote $addr; return $addr =~ m/^ $rx $/x; } diff --git a/src/tools/DBD/Menu.pm b/src/tools/DBD/Menu.pm index 65bae1526..244234f20 100644 --- a/src/tools/DBD/Menu.pm +++ b/src/tools/DBD/Menu.pm @@ -13,8 +13,7 @@ sub init { sub add_choice { my ($this, $name, $value) = @_; - $name = identifier($name, "Choice name"); - unquote $value; + $name = $this->identifier($name, "Choice name"); foreach $pair ($this->choices) { dieContext("Duplicate menu choice name '$name'") if ($pair->[0] eq $name); @@ -36,7 +35,6 @@ sub choice { sub legal_choice { my ($this, $value) = @_; - unquote $value; return exists $this->{CHOICE_INDEX}->{$value}; } diff --git a/src/tools/DBD/Output.pm b/src/tools/DBD/Output.pm index a338358b3..6e9d67b3c 100644 --- a/src/tools/DBD/Output.pm +++ b/src/tools/DBD/Output.pm @@ -1,9 +1,12 @@ package DBD::Output; +use strict; +use warnings; + require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(&OutputDBD); +our @ISA = qw(Exporter); +our @EXPORT = qw(&OutputDBD &OutputDB); use DBD; use DBD::Base; @@ -13,6 +16,7 @@ use DBD::Driver; use DBD::Menu; use DBD::Recordtype; use DBD::Recfield; +use DBD::Record; use DBD::Registrar; use DBD::Function; use DBD::Variable; @@ -28,6 +32,11 @@ sub OutputDBD { OutputBreaktables($out, $dbd->breaktables); } +sub OutputDB { + my ($out, $dbd) = @_; + OutputRecords($out, $dbd->records); +} + sub OutputMenus { my ($out, $menus) = @_; while (my ($name, $menu) = each %{$menus}) { @@ -44,7 +53,7 @@ sub OutputRecordtypes { printf $out "recordtype(%s) {\n", $name; print $out " %$_\n" foreach $recordtype->cdefs; - foreach $field ($recordtype->fields) { + foreach my $field ($recordtype->fields) { printf $out " field(%s, %s) {\n", $field->name, $field->dbf_type; while (my ($attr, $val) = each %{$field->attributes}) { @@ -98,4 +107,23 @@ sub OutputBreaktables { } } +sub OutputRecords { + my ($out, $records) = @_; + while (my ($name, $rec) = each %{$records}) { + next if $name ne $rec->name; # Alias + printf $out "record(%s, \"%s\") {\n", $rec->recordtype->name, $name; + printf $out " alias(\"%s\")\n", $_ + foreach $rec->aliases; + foreach my $recfield ($rec->recfields) { + my $field_name = $recfield->name; + my $value = $rec->get_field($field_name); + printf $out " field(%s, \"%s\")\n", $field_name, $value + if defined $value; + } + printf $out " info(\"%s\", \"%s\")\n", $_, $rec->info_value($_) + foreach $rec->info_names; + print $out "}\n"; + } +} + 1; diff --git a/src/tools/DBD/Parser.pm b/src/tools/DBD/Parser.pm index 3fbf2f99d..fa33bf26e 100644 --- a/src/tools/DBD/Parser.pm +++ b/src/tools/DBD/Parser.pm @@ -1,8 +1,12 @@ package DBD::Parser; + +use strict; +use warnings; + require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(&ParseDBD); +our @ISA = qw(Exporter); +our @EXPORT = qw(&ParseDBD); use DBD; use DBD::Base; @@ -12,6 +16,7 @@ use DBD::Driver; use DBD::Menu; use DBD::Recordtype; use DBD::Recfield; +use DBD::Record; use DBD::Registrar; use DBD::Function; use DBD::Variable; @@ -24,46 +29,72 @@ sub ParseDBD { parseCommon($dbd); if (m/\G menu \s* \( \s* $RXstr \s* \) \s* \{/oxgc) { print "Menu: $1\n" if $debug; - parse_menu($dbd, $1); + my ($menu_name) = unquote($1); + parse_menu($dbd, $menu_name); } elsif (m/\G driver \s* \( \s* $RXstr \s* \)/oxgc) { print "Driver: $1\n" if $debug; - $dbd->add(DBD::Driver->new($1)); + my ($driver_name) = unquote($1); + $dbd->add(DBD::Driver->new($driver_name)); } elsif (m/\G registrar \s* \( \s* $RXstr \s* \)/oxgc) { print "Registrar: $1\n" if $debug; - $dbd->add(DBD::Registrar->new($1)); + my ($registrar_name) = unquote($1); + $dbd->add(DBD::Registrar->new($registrar_name)); } elsif (m/\G function \s* \( \s* $RXstr \s* \)/oxgc) { print "Function: $1\n" if $debug; - $dbd->add(DBD::Function->new($1)); + my ($function_name) = unquote($1); + $dbd->add(DBD::Function->new($function_name)); } elsif (m/\G breaktable \s* \( \s* $RXstr \s* \) \s* \{/oxgc) { print "Breaktable: $1\n" if $debug; - parse_breaktable($dbd, $1); + my ($breaktable_name) = unquote($1); + parse_breaktable($dbd, $breaktable_name); } elsif (m/\G recordtype \s* \( \s* $RXstr \s* \) \s* \{/oxgc) { print "Recordtype: $1\n" if $debug; - parse_recordtype($dbd, $1); + my ($recordtype_name) = unquote($1); + parse_recordtype($dbd, $recordtype_name); + } + elsif (m/\G g?record \s* \( \s* $RXstr \s*, \s* $RXstr \s* \) \s* \{/oxgc) { + print "Record: $1, $2\n" if $debug; + my ($record_type, $record_name) = unquote($1, $2); + parse_record($dbd, $record_type, $record_name); + } + elsif (m/\G alias \s* \( \s* $RXstr \s*, \s* $RXstr \s* \)/oxgc) { + print "Alias: $1, $2\n" if $debug; + my ($record_name, $alias) = unquote($1, $2); + my $rec = $dbd->record($record_name); + dieContext("Alias '$alias' refers to unknown record '$record_name'") + unless defined $rec; + dieContext("Can't create alias '$alias', name already used") + if defined $dbd->record($alias); + $rec->add_alias($alias); + $dbd->add($rec, $alias); } elsif (m/\G variable \s* \( \s* $RXstr \s* \)/oxgc) { print "Variable: $1\n" if $debug; - $dbd->add(DBD::Variable->new($1)); + my ($variable_name) = unquote($1); + $dbd->add(DBD::Variable->new($variable_name)); } elsif (m/\G variable \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) { print "Variable: $1, $2\n" if $debug; - $dbd->add(DBD::Variable->new($1, $2)); + my ($variable_name, $variable_type) = unquote($1, $2); + $dbd->add(DBD::Variable->new($variable_name, $variable_type)); } elsif (m/\G device \s* \( \s* $RXstr \s* , \s* $RXstr \s* , \s* $RXstr \s* , \s*$RXstr \s* \)/oxgc) { print "Device: $1, $2, $3, $4\n" if $debug; - my $rtyp = $dbd->recordtype($1); + my ($record_type, $link_type, $dset, $choice) = + unquote($1, $2, $3, $4); + my $rtyp = $dbd->recordtype($record_type); if (!defined $rtyp) { - $rtyp = DBD::Recordtype->new($1); - warn "Device using undefined record type '$1', place-holder created\n"; + $rtyp = DBD::Recordtype->new($record_type); + warn "Device using undefined record type '$record_type', place-holder created\n"; $dbd->add($rtyp); } - $rtyp->add_device(DBD::Device->new($2, $3, $4)); + $rtyp->add_device(DBD::Device->new($link_type, $dset, $choice)); } else { last unless m/\G (.*) $/moxgc; dieContext("Syntax error in '$1'"); @@ -101,6 +132,10 @@ sub parseCommon { } } +sub unquote { + return map { m/^ ("?) (.*) \1 $/ox; $2 } @_; +} + sub parsePod { pushContext("Pod markup"); my @pod; @@ -119,19 +154,20 @@ sub parsePod { } sub parse_menu { - my ($dbd, $name) = @_; - pushContext("menu($name)"); - my $menu = DBD::Menu->new($name); + my ($dbd, $menu_name) = @_; + pushContext("menu($menu_name)"); + my $menu = DBD::Menu->new($menu_name); while(1) { parseCommon($menu); if (m/\G choice \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) { print " Menu-Choice: $1, $2\n" if $debug; - $menu->add_choice($1, $2); + my ($choice_name, $value) = unquote($1, $2); + $menu->add_choice($choice_name, $value); } elsif (m/\G \}/oxgc) { print " Menu-End:\n" if $debug; $dbd->add($menu); - popContext("menu($name)"); + popContext("menu($menu_name)"); return; } else { m/\G (.*) $/moxgc or dieContext("Unexpected end of input"); @@ -141,23 +177,25 @@ sub parse_menu { } sub parse_breaktable { - my ($dbd, $name) = @_; - pushContext("breaktable($name)"); - my $bt = DBD::Breaktable->new($name); + my ($dbd, $breaktable_name) = @_; + pushContext("breaktable($breaktable_name)"); + my $bt = DBD::Breaktable->new($breaktable_name); while(1) { parseCommon($bt); if (m/\G point\s* \(\s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) { print " Breaktable-Point: $1, $2\n" if $debug; - $bt->add_point($1, $2); + my ($raw, $eng) = unquote($1, $2); + $bt->add_point($raw, $eng); } elsif (m/\G $RXstr \s* (?: , \s*)? $RXstr (?: \s* ,)?/oxgc) { print " Breaktable-Data: $1, $2\n" if $debug; - $bt->add_point($1, $2); + my ($raw, $eng) = unquote($1, $2); + $bt->add_point($raw, $eng); } elsif (m/\G \}/oxgc) { print " Breaktable-End:\n" if $debug; $dbd->add($bt); - popContext("breaktable($name)"); + popContext("breaktable($breaktable_name)"); return; } else { m/\G (.*) $/moxgc or dieContext("Unexpected end of input"); @@ -167,24 +205,64 @@ sub parse_breaktable { } sub parse_recordtype { - my ($dbd, $name) = @_; - pushContext("recordtype($name)"); - my $rtyp = DBD::Recordtype->new($name); + my ($dbd, $record_type) = @_; + pushContext("recordtype($record_type)"); + my $rtyp = DBD::Recordtype->new($record_type); while(1) { parseCommon($rtyp); if (m/\G field \s* \( \s* $RXstr \s* , \s* $RXstr \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; + my ($field_name, $field_type) = unquote($1, $2); + parse_field($rtyp, $field_name, $field_type); } elsif (m/\G % (.*) \n/oxgc) { print " Recordtype-Cdef: $1\n" if $debug; $rtyp->add_cdef($1); + } + elsif (m/\G \}/oxgc) { + print " Recordtype-End:\n" if $debug; + $dbd->add($rtyp); + popContext("recordtype($record_type)"); + return; + } else { + m/\G (.*) $/moxgc or dieContext("Unexpected end of input"); + dieContext("Syntax error in '$1'"); + } + } +} + +sub parse_record { + my ($dbd, $record_type, $record_name) = @_; + pushContext("record($record_type, $record_name)"); + my $rtyp = $dbd->recordtype($record_type); + dieContext("No recordtype named '$record_type'") + unless defined $rtyp; + my $rec = DBD::Record->new($rtyp, $record_name); # FIXME: Merge duplicates + while(1) { + parseCommon($rec); + if (m/\G field \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) { + print " Record-Field: $1, $2\n" if $debug; + my ($field_name, $value) = unquote($1, $2); + $rec->put_field($field_name, $value); + } + elsif (m/\G info \s* \( \s* $RXstr \s* , \s* $RXstr \s* \)/oxgc) { + print " Record-Info: $1, $2\n" if $debug; + my ($info_name, $value) = unquote($1, $2); + $rec->add_info($info_name, $value); + } + elsif (m/\G alias \s* \( \s* $RXstr \s* \)/oxgc) { + print " Record-Alias: $1\n" if $debug; + my ($alias) = unquote($1); + dieContext("Can't create alias '$alias', name in use") + if defined $dbd->record($1); + $rec->add_alias($alias); + $dbd->add($rec, $alias); + } + elsif (m/\G \}/oxgc) { + print " Record-End:\n" if $debug; + $dbd->add($rec); + popContext("record($record_type, $record_name)"); + return; } else { m/\G (.*) $/moxgc or dieContext("Unexpected end of input"); dieContext("Syntax error in '$1'"); @@ -193,19 +271,20 @@ sub parse_recordtype { } sub parse_field { - my ($rtyp, $name, $field_type) = @_; - my $fld = DBD::Recfield->new($name, $field_type); - pushContext("field($name, $field_type)"); + my ($rtyp, $field_name, $field_type) = @_; + my $fld = DBD::Recfield->new($field_name, $field_type); + pushContext("field($field_name, $field_type)"); while(1) { parseCommon($fld); if (m/\G (\w+) \s* \( \s* $RXstr \s* \)/oxgc) { print " Field-Attribute: $1, $2\n" if $debug; - $fld->add_attribute($1, $2); + my ($attr, $value) = unquote($1, $2); + $fld->add_attribute($attr, $value); } elsif (m/\G \}/oxgc) { print " Field-End:\n" if $debug; $rtyp->add_field($fld); - popContext("field($name, $field_type)"); + popContext("field($field_name, $field_type)"); return; } else { m/\G (.*) $/moxgc or dieContext("Unexpected end of input"); diff --git a/src/tools/DBD/Recfield.pm b/src/tools/DBD/Recfield.pm index 6dbf1696f..d38a081fa 100644 --- a/src/tools/DBD/Recfield.pm +++ b/src/tools/DBD/Recfield.pm @@ -50,7 +50,6 @@ sub new { sub init { my ($this, $name, $type) = @_; - unquote $type; $this->SUPER::init($name, "record field"); dieContext("Illegal field type '$type', valid field types are:", sort keys %field_types) unless exists $field_types{$type}; @@ -75,7 +74,6 @@ sub number { sub add_attribute { my ($this, $attr, $value) = @_; - unquote $value; my $match = $field_attrs{$attr}; if (defined $match) { dieContext("Bad value '$value' for field attribute '$attr'") diff --git a/src/tools/DBD/Record.pm b/src/tools/DBD/Record.pm new file mode 100644 index 000000000..1b7980c2d --- /dev/null +++ b/src/tools/DBD/Record.pm @@ -0,0 +1,123 @@ +package DBD::Record; + +use strict; +use warnings; + +use DBD::Base; + +our @ISA = qw(DBD::Base); + +use Carp; + +our ($macrosOk); +my $warned; + +sub init { + my ($this, $type, $name) = @_; + confess "DBD::Record::init: Not a DBD::Recordtype" + unless $type->isa('DBD::Recordtype'); + $this->SUPER::init($name, "record"); + $this->{RECORD_TYPE} = $type; + $this->{ALIASES} = []; + $this->{RECFIELD_LIST} = []; + $this->{FIELD_INDEX} = {}; + $this->{INFO_LIST} = []; + $this->{INFO_ITEMS} = {}; + $this->{COMMENTS} = []; + $this->{POD} = []; + return $this; +} + +# Override, record names are not as strict as recordtype and menu names +sub identifier { + my ($this, $id, $what) = @_; + confess "DBD::Record::identifier: $what undefined!" + unless defined $id; + if ($macrosOk) { + # FIXME - Check name with macro + } + elsif ($id !~ m/^$RXname$/o) { + my @message; + push @message, "A $what should contain only letters, digits and these", + "special characters: _ - : . [ ] < > ;" unless $warned++; + warnContext("Deprecated $what '$id'", @message); + } + return $id; +} + +sub recordtype { + return shift->{RECORD_TYPE}; +} + +sub add_alias { + my ($this, $alias) = @_; + push @{$this->{ALIASES}}, $this->identifier($alias, "alias name"); +} + +sub aliases { + return @{shift->{ALIASES}}; +} + +sub put_field { + my ($this, $field_name, $value) = @_; + my $recfield = $this->{RECORD_TYPE}->field($field_name); + dieContext("No field named '$field_name'") + unless defined $recfield; + dieContext("Can't set $field_name to '$value'") + unless $recfield->legal_value($value); + push @{$this->{RECFIELD_LIST}}, $recfield + unless exists $this->{FIELD_INDEX}->{$field_name}; + $this->{FIELD_INDEX}->{$field_name} = $value; +} + +sub recfields { + return @{shift->{RECFIELD_LIST}}; +} + +sub field_names { # In their original order... + return map {$_->name} @{shift->{RECFIELD_LIST}}; +} + +sub get_field { + my ($this, $field_name) = @_; + return $this->{FIELD_INDEX}->{$field_name} + if exists $this->{FIELD_INDEX}->{$field_name}; + my $recfield = $this->{RECORD_TYPE}->field($field_name); + return $recfield->attribute("initial"); +} + +sub add_info { + my ($this, $info_name, $value) = @_; + push @{$this->{INFO_LIST}}, $info_name + unless exists $this->{INFO_ITEMS}->{$info_name}; + $this->{INFO_ITEMS}->{$info_name} = $value; +} + +sub info_names { + return @{shift->{INFO_LIST}}; +} + +sub info_value { + my ($this, $info_name) = @_; + return $this->{INFO_ITEMS}->{$info_name}; +} + +sub add_comment { + my ($this, $comment) = @_; + push @{$this->{COMMENTS}}, $comment; +} + +sub comments { + return @{shift->{COMMENTS}}; +} + +sub add_pod { + my $this = shift; + push @{$this->{POD}}, @_; +} + +sub pod { + return @{shift->{POD}}; +} + +1; diff --git a/src/tools/DBD/Variable.pm b/src/tools/DBD/Variable.pm index 87ea6d47a..cd1b0a334 100644 --- a/src/tools/DBD/Variable.pm +++ b/src/tools/DBD/Variable.pm @@ -10,11 +10,7 @@ my %valid_types = ( sub init { my ($this, $name, $type) = @_; - if (defined $type) { - unquote $type; - } else { - $type = "int"; - } + $type = "int" unless defined $type; exists $valid_types{$type} or dieContext("Unknown variable type '$type', valid types are:", sort keys %valid_types); diff --git a/src/tools/EPICS/macLib.pm b/src/tools/EPICS/macLib.pm index 332ceca67..9ae40314e 100644 --- a/src/tools/EPICS/macLib.pm +++ b/src/tools/EPICS/macLib.pm @@ -122,7 +122,8 @@ sub suppressWarning($$) { sub expandString($$) { my ($this, $src) = @_; $this->_expand; - my $entry = EPICS::macLib::entry->new($src, 'string'); + (my $name = $src) =~ s/^ (.{20}) .* $/$1.../xs; + my $entry = EPICS::macLib::entry->new($name, 'string'); my $result = $this->_translate($entry, 0, $src); return $result unless $entry->{error}; return $this->{noWarn} ? $result : undef; diff --git a/src/tools/Makefile b/src/tools/Makefile index 26da8f550..580e32cb6 100644 --- a/src/tools/Makefile +++ b/src/tools/Makefile @@ -29,6 +29,7 @@ PERL_MODULES += DBD/Output.pm PERL_MODULES += DBD/Parser.pm PERL_MODULES += DBD/Recfield.pm PERL_MODULES += DBD/Recordtype.pm +PERL_MODULES += DBD/Record.pm PERL_MODULES += DBD/Registrar.pm PERL_MODULES += DBD/Variable.pm @@ -49,6 +50,7 @@ PERL_SCRIPTS += useManifestTool.pl PERL_SCRIPTS += dbdToMenuH.pl PERL_SCRIPTS += dbdToRecordtypeH.pl PERL_SCRIPTS += dbdExpand.pl +PERL_SCRIPTS += dbExpand.pl PERL_SCRIPTS += dbdToHtml.pl PERL_SCRIPTS += podToHtml.pl PERL_SCRIPTS += podRemove.pl diff --git a/src/tools/dbExpand.pl b/src/tools/dbExpand.pl new file mode 100644 index 000000000..abfea833b --- /dev/null +++ b/src/tools/dbExpand.pl @@ -0,0 +1,88 @@ +#!/usr/bin/env perl + +#************************************************************************* +# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne +# National Laboratory. +# EPICS BASE is distributed subject to a Software License Agreement found +# in file LICENSE that is included with this distribution. +#************************************************************************* + +# $Id$ + +use strict; + +use FindBin qw($Bin); +use lib "$Bin/../../lib/perl"; + +use DBD; +use DBD::Parser; +use DBD::Output; +use EPICS::Getopts; +use EPICS::Readfile; +use EPICS::macLib; + +our ($opt_D, @opt_I, @opt_S, $opt_o, $opt_V); + +getopts('DI@S@o:V') or + die "Usage: dbExpand [-D] [-I dir] [-S macro=val] [-o out.db] in.dbd in.db ..."; + +my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32? +my $macros = EPICS::macLib->new(@opt_S); +my $dbd = DBD->new(); + +$macros->suppressWarning(!$opt_V); +$DBD::Record::macrosOk = !$opt_V; + +# Calculate filename for the dependency warning message below +my $dep = $opt_o; +my $dot_d = ''; +if ($opt_D) { + $dep =~ s{\.\./O\.Common/(.*)}{$1\$\(DEP\)}; + $dot_d = '.d'; +} else { + $dep = "\$(COMMON_DIR)/$dep"; +} + +die "dbExpand.pl: No input files for $opt_o\n" if !@ARGV; + +my $errors = 0; + +while (@ARGV) { + my $file = shift @ARGV; + eval { + &ParseDBD($dbd, &Readfile($file, $macros, \@opt_I)); + }; + if ($@) { + warn "dbExpand.pl: $@"; + my $outfile = $opt_o ? " to create '$opt_o$dot_d'" : ''; + warn " while reading '$file'$outfile\n"; + warn " Your Makefile may need this dependency rule:\n", + " $dep: \$(COMMON_DIR)/$file\n" + if $@ =~ m/Can't find file '$file'/; + ++$errors; + } +} + +if ($opt_D) { # Output dependencies only, ignore errors + my %filecount; + my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles; + print "$opt_o: ", join(" \\\n ", @uniqfiles), "\n\n"; + print map { "$_:\n" } @uniqfiles; + exit 0; +} + +die "dbExpand.pl: Exiting due to errors\n" if $errors; + +my $out; +if ($opt_o) { + open $out, '>', $opt_o or die "Can't create $opt_o: $!\n"; +} else { + $out = *STDOUT; +} + +&OutputDB($out, $dbd); + +if ($opt_o) { + close $out or die "Closing $opt_o failed: $!\n"; +} +exit 0; diff --git a/src/tools/dbdExpand.pl b/src/tools/dbdExpand.pl old mode 100755 new mode 100644 index 96398e703..f111bd98d --- a/src/tools/dbdExpand.pl +++ b/src/tools/dbdExpand.pl @@ -1,4 +1,4 @@ -#!/usr/bin/perl +#!/usr/bin/env perl #************************************************************************* # Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne @@ -9,6 +9,8 @@ # $Id$ +use strict; + use FindBin qw($Bin); use lib "$Bin/../../lib/perl"; @@ -19,6 +21,8 @@ use EPICS::Getopts; use EPICS::Readfile; use EPICS::macLib; +our ($opt_D, @opt_I, @opt_S, $opt_o); + getopts('DI@S@o:') or die "Usage: dbdExpand [-D] [-I dir] [-S macro=val] [-o out.dbd] in.dbd ..."; @@ -69,7 +73,7 @@ my $out; if ($opt_o) { open $out, '>', $opt_o or die "Can't create $opt_o: $!\n"; } else { - $out = STDOUT; + $out = *STDOUT; } OutputDBD($out, $dbd); diff --git a/src/tools/dbdReport.pl b/src/tools/dbdReport.pl old mode 100755 new mode 100644 index 9d1bd068e..a90a9c9c0 --- a/src/tools/dbdReport.pl +++ b/src/tools/dbdReport.pl @@ -32,7 +32,7 @@ my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32? my $macros = EPICS::macLib->new(@opt_S); my $dbd = DBD->new(); -ParseDBD($dbd, Readfile(shift @ARGV, $macros, \@opt_I)); +ParseDBD($dbd, Readfile(shift @ARGV, $macros, \@opt_I)) while @ARGV; $Text::Wrap::columns = 75; @@ -62,3 +62,7 @@ if (%recordtypes) { if @devices; } } +my @records = sort keys %{$dbd->records}; +print wrap("Records: ", "\t", join(', ', @records)), "\n" + if @records; + diff --git a/src/tools/dbdToMenuH.pl b/src/tools/dbdToMenuH.pl old mode 100755 new mode 100644 diff --git a/src/tools/dbdToRecordtypeH.pl b/src/tools/dbdToRecordtypeH.pl old mode 100755 new mode 100644 diff --git a/src/tools/test/Device.plt b/src/tools/test/Device.plt index d362054c2..79f96bfd0 100644 --- a/src/tools/test/Device.plt +++ b/src/tools/test/Device.plt @@ -7,7 +7,7 @@ use Test::More tests => 16; use DBD::Device; -my $dev = DBD::Device->new('VME_IO', 'test', '"Device"'); +my $dev = DBD::Device->new('VME_IO', 'test', 'Device'); isa_ok $dev, 'DBD::Device'; is $dev->name, 'test', 'Device name'; is $dev->link_type, 'VME_IO', 'Link type'; @@ -27,7 +27,7 @@ my %dev_addrs = ( INST_IO => '@Anything' ); while (my ($link, $addr) = each(%dev_addrs)) { - $dev->init($link, 'test', '"Device"'); + $dev->init($link, 'test', 'Device'); ok $dev->legal_addr($addr), "$link address"; } diff --git a/src/tools/test/Menu.plt b/src/tools/test/Menu.plt index f8da94b97..97305b8a9 100644 --- a/src/tools/test/Menu.plt +++ b/src/tools/test/Menu.plt @@ -11,11 +11,11 @@ my $menu = DBD::Menu->new('test'); isa_ok $menu, 'DBD::Menu'; is $menu->name, 'test', 'Menu name'; is $menu->choices, 0, 'Choices == zero'; -$menu->add_choice('ch1', '"Choice 1"'); +$menu->add_choice('ch1', 'Choice 1'); is $menu->choices, 1, 'First choice added'; ok $menu->legal_choice('Choice 1'), 'First choice legal'; is_deeply $menu->choice(0), ['ch1', 'Choice 1'], 'First choice found'; -$menu->add_choice('ch2', '"Choice 2"'); +$menu->add_choice('ch2', 'Choice 2'); is $menu->choices, 2, 'Second choice added'; ok $menu->legal_choice('Choice 1'), 'First choice still legal'; is_deeply $menu->choice(0), ['ch1', 'Choice 1'], 'First choice still found';