From 38e1b910a516b273af3a8a16c50c0039790844c9 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 15:44:53 -0500 Subject: [PATCH 01/32] 2004-04-29: work in progress --- src/dbHost/Getopts.pm | 76 +++++++++ src/dbHost/ReadDBD.pm | 350 +++++++++++++++++++++++++++++++++++++++++ src/dbHost/Readfile.pm | 101 ++++++++++++ src/dbHost/dbExpand | 34 ++++ src/dbHost/dbToMenuH | 52 ++++++ src/dbHost/dbdReport | 42 +++++ 6 files changed, 655 insertions(+) create mode 100644 src/dbHost/Getopts.pm create mode 100644 src/dbHost/ReadDBD.pm create mode 100644 src/dbHost/Readfile.pm create mode 100755 src/dbHost/dbExpand create mode 100755 src/dbHost/dbToMenuH create mode 100755 src/dbHost/dbdReport diff --git a/src/dbHost/Getopts.pm b/src/dbHost/Getopts.pm new file mode 100644 index 000000000..53b08e447 --- /dev/null +++ b/src/dbHost/Getopts.pm @@ -0,0 +1,76 @@ +package Getopts; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(getopts); + +# getopts.pl - our getopts stuff +# +# This version of getopts is modified from the Perl original in the +# following ways: +# +# 1. The perl routine in GetOpt::Std allows a perl hash to be passed +# in as a third argument and used for storing option values. This +# functionality has been deleted. +# 2. Arguments without a ':' modifier are now counted, rather than +# being binary. This means that multiple copies of the same option +# can be detected by the program. +# 3. A new '@' modifier is provided which collects the option arguments +# in an array @opt_X. Multiple copies of this option are permitted +# and push the arguments onto the end of the list. + +sub getopts ( $;$ ) { + my ($argumentative) = @_; + my (@args,$first,$rest); + my $errs = 0; + local $_; + local @EXPORT; + + @args = split( / */, $argumentative ); + while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { + ($first,$rest) = ($1,$2); + if (/^--$/) { # early exit if -- + shift @ARGV; + last; + } + $pos = index($argumentative,$first); + if ($pos >= 0) { + if (defined($args[$pos+1]) and (index(':@', $args[$pos+1]) >= 0)) { + shift(@ARGV); + if ($rest eq '') { + ++$errs unless @ARGV; + $rest = shift(@ARGV); + } + if ($args[$pos+1] eq ':') { + ${"opt_$first"} = $rest; + push @EXPORT, "\$opt_$first"; + } elsif ($args[$pos+1] eq '@') { + push @{"opt_$first"}, $rest; + push @EXPORT, "\@opt_$first"; + } + } else { + ${"opt_$first"} += 1; + push @EXPORT, "\$opt_$first"; + if ($rest eq '') { + shift(@ARGV); + } else { + $ARGV[0] = "-$rest"; + } + } + } else { + warn "Unknown option: $first\n"; + ++$errs; + if ($rest ne '') { + $ARGV[0] = "-$rest"; + } else { + shift(@ARGV); + } + } + } + local $Exporter::ExportLevel = 1; + import Getopts; + $errs == 0; +} + +1; diff --git a/src/dbHost/ReadDBD.pm b/src/dbHost/ReadDBD.pm new file mode 100644 index 000000000..46cdd68c6 --- /dev/null +++ b/src/dbHost/ReadDBD.pm @@ -0,0 +1,350 @@ +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 new file mode 100644 index 000000000..755c030b6 --- /dev/null +++ b/src/dbHost/Readfile.pm @@ -0,0 +1,101 @@ +package Readfile; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(@inputfiles &Readfile); + +our $debug=0; +our @inputfiles; + +sub slurp { + my ($FILE, $Rpath) = @_; + my @path = @{$Rpath}; + print "slurp($FILE):\n" if $debug; + if ($FILE !~ m[/]) { + foreach $dir (@path) { + print " trying $dir/$FILE\n" if $debug; + if (-r "$dir/$FILE") { + $FILE = "$dir/$FILE"; + last; + } + } + die "Can't find file '$FILE'\n" unless -r $FILE; + } + print " opening $FILE\n" if $debug; + open FILE, "<$FILE" or die "Can't open $FILE: $!\n"; + push @inputfiles, $FILE; + my @lines = ("##!BEGIN{$FILE}!##\n"); + push @lines, ; + push @lines, "##!END{$FILE}!##\n"; + close FILE or die "Error closing $FILE: $!\n"; + print " read ", scalar @lines, " lines\n" if $debug; + return @lines; +} + +sub macval { + my ($macro, $Rmacros) = @_; + if (exists $Rmacros->{$macro}) { + return $Rmacros->{$macro}; + } else { + warn "Warning: No value for macro \$($macro)\n"; + return undef; + } +} + +sub expandMacros { + my ($Rmacros, @input) = @_; + my @output; + foreach (@input) { + s/\$\((\w+)\)/&macval($1, $Rmacros)/eg unless /^\s*#/; + push @output, $_; + } + return @output; +} + +sub splitPath { + my ($path) = @_; + my (@path) = split /[:;]/, $path; + grep s/^$/./, @path; + return @path; +} + +my $RXstr = qr/ " (?: [^"] | \\" )* "/ox; +my $RXnam = qr/[a-zA-Z0-9_\-:.[\]<>;]+/o; +my $string = qr/ ( $RXnam | $RXstr ) /ox; + +sub unquote { + my ($string) = @_; + $string = $1 if $string =~ m/^"(.*)"$/o; + return $string; +} + +sub Readfile { + my ($file, $Rmacros, $Rpath) = @_; + print "Readfile($file)\n" if $debug; + my @input = &expandMacros($Rmacros, &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); + } elsif (m/^ \s* addpath \s+ $string /ox) { + $arg = &unquote($1); + print " addpath $arg\n" if $debug; + push @output, "##! addpath \"$arg\"\n"; + push @{$Rpath}, &splitPath($arg); + } elsif (m/^ \s* path \s+ $string /ox) { + $arg = &unquote($1); + print " path $arg\n" if $debug; + push @output, "##! path \"$arg\"\n"; + @{$Rpath} = &splitPath($arg); + } else { + push @output, $_; + } + } + return @output; +} + +1; diff --git a/src/dbHost/dbExpand b/src/dbHost/dbExpand new file mode 100755 index 000000000..1f9dd1337 --- /dev/null +++ b/src/dbHost/dbExpand @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +# This version of dbExpand does not syntax check its input files or remove +# duplicate definitions, unlike the dbStaticLib version. It does do the +# include file expansion and macro substitution though. + +use Getopts; +use Readfile; + +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; + +while (@ARGV) { + my @file = &Readfile(shift @ARGV, \%macros, \@opt_I); + # Strip the stuff that Readfile() added: + push @output, grep !/^\#\#!/, @file +} + +if ($opt_D) { + my %filecount; + my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles; + print "$opt_o: ", join(" \\\n ", @uniqfiles), "\n\n"; + print map { "$_:\n" } @uniqfiles; +} elsif ($opt_o) { + open OUTFILE, ">$opt_o" or die "Can't create $opt_o: $!\n"; + print OUTFILE @output; + close OUTFILE; +} else { + print @output; +} diff --git a/src/dbHost/dbToMenuH b/src/dbHost/dbToMenuH new file mode 100755 index 000000000..e99929fa9 --- /dev/null +++ b/src/dbHost/dbToMenuH @@ -0,0 +1,52 @@ +#!/usr/bin/perl + +use ReadDBD; +use Getopts; +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 $infile = shift @ARGV; +$infile =~ m/\.dbd$/ or + die "Input file '$infile' must have '.dbd' extension\n"; + +my $outfile; +if ($opt_o) { + $outfile = $opt_o; +} elsif (@ARGV) { + $outfile = shift @ARGV; +} else { + ($outfile = $infile) =~ s/\.dbd$/.h/; +} + +# Derive a name for the include guard +($guard_name = $outfile) =~ tr/a-zA-Z0-9_/_/cs; +$guard_name =~ s/(_[hH])?$/_H/; + +&ParseDBD(&Readfile($infile, \%macros, \@opt_I)); + +if ($opt_D) { + my %filecount; + my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles; + print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n"; + print map { "$_:\n" } @uniqfiles; +} else { + open OUTFILE, ">$outfile" or die "Can't open $outfile: $!\n"; + 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); + } + 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 new file mode 100755 index 000000000..6c94e7212 --- /dev/null +++ b/src/dbHost/dbdReport @@ -0,0 +1,42 @@ +#!/usr/bin/perl + +use ReadDBD; +use Getopts; +use Readfile; +use Text::Wrap; + +#$Readfile::debug = 1; +#$ReadDBD::debug = 1; + +getopts('I@S@') or die usage(); + +sub usage() { + "Usage: dbdReport [-I dir] [-S macro=val] file.dbd"; +} + +my @path = map { split /[:;]/ } @opt_I; +my %macros = map { split /=/ } map { split /,/ } @opt_S; + +&ParseDBD(&Readfile(shift @ARGV, \%macros, \@opt_I)); + +$Text::Wrap::columns = 70; + +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; +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{$_}; + } +} From a996fc6c06876ba3a1434a4191f5c46e1d94b7b7 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 15:47:07 -0500 Subject: [PATCH 02/32] 2004-06-04: Sync laptop => CVS --- src/dbHost/DBD.pm | 57 +++++++++++++++++++++ src/dbHost/DBD/Breaktable.pm | 32 ++++++++++++ src/dbHost/DBD/Device.pm | 44 +++++++++++++++++ src/dbHost/DBD/Driver.pm | 9 ++++ src/dbHost/DBD/Function.pm | 9 ++++ src/dbHost/DBD/Menu.pm | 40 +++++++++++++++ src/dbHost/DBD/Recfield.pm | 96 ++++++++++++++++++++++++++++++++++++ src/dbHost/DBD/Recordtype.pm | 75 ++++++++++++++++++++++++++++ src/dbHost/DBD/Registrar.pm | 10 ++++ src/dbHost/DBD/Util.pm | 85 +++++++++++++++++++++++++++++++ src/dbHost/DBD/Variable.pm | 27 ++++++++++ 11 files changed, 484 insertions(+) create mode 100644 src/dbHost/DBD.pm create mode 100644 src/dbHost/DBD/Breaktable.pm create mode 100644 src/dbHost/DBD/Device.pm create mode 100644 src/dbHost/DBD/Driver.pm create mode 100644 src/dbHost/DBD/Function.pm create mode 100644 src/dbHost/DBD/Menu.pm create mode 100644 src/dbHost/DBD/Recfield.pm create mode 100644 src/dbHost/DBD/Recordtype.pm create mode 100644 src/dbHost/DBD/Registrar.pm create mode 100644 src/dbHost/DBD/Util.pm create mode 100644 src/dbHost/DBD/Variable.pm diff --git a/src/dbHost/DBD.pm b/src/dbHost/DBD.pm new file mode 100644 index 000000000..1cf82cc8a --- /dev/null +++ b/src/dbHost/DBD.pm @@ -0,0 +1,57 @@ +package DBD; + +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; + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $this = { + BREAKTABLES => {}, + DEVICES => {}, + DRIVERS => {}, + MENUS => {}, + RECORDTYPES => {}, + REGISTRARS => {}, + FUNCTIONS => {}, + VARIABLES => {} + }; + bless $this, $class; + return $this; +} + +sub add_breaktable { +} + +sub add_driver { +} + +sub add_menu { +} + +sub add_recordtype { +} + +sub add_registrar { +} + +sub add_function { +} + +sub add_variable { + my ($this, $obj) = @_; + confess "Not a DBD::Variable" unless $obj->isa('DBD::Variable'); + my $obj_name = $obj->name; + dieContext("Duplicate variable '$obj_name'") + if exists $this->{VARIABLES}->{$obj_name}; + $this->{VARIABLES}->{$obj_name} = $obj; +} + +1; diff --git a/src/dbHost/DBD/Breaktable.pm b/src/dbHost/DBD/Breaktable.pm new file mode 100644 index 000000000..b36067aa1 --- /dev/null +++ b/src/dbHost/DBD/Breaktable.pm @@ -0,0 +1,32 @@ +package DBD::Breaktable; +use DBD::Util; +@ISA = qw(DBD::Util); + +use Carp; + +sub init { + my ($this, $name) = @_; + $this->SUPER::init($name, "breakpoint table name"); + $this->{POINTS} = []; + return $this; +} + +sub add_point { + my ($this, $raw, $eng) = @_; + confess "Raw value undefined!" unless defined $raw; + $raw = unquote($raw); + confess "Engineering value undefined!" unless defined $eng; + $eng = unquote($eng); + push @{$this->{POINTS}}, [$raw, $eng]; +} + +sub points { + return @{shift->{POINTS}}; +} + +sub point { + my ($this, $idx) = @_; + return $this->{POINTS}[$idx]; +} + +1; diff --git a/src/dbHost/DBD/Device.pm b/src/dbHost/DBD/Device.pm new file mode 100644 index 000000000..c59d20f9f --- /dev/null +++ b/src/dbHost/DBD/Device.pm @@ -0,0 +1,44 @@ +package DBD::Device; +use DBD::Util; +@ISA = qw(DBD::Util); + +my %link_types = ( + CONSTANT => qr/$RXnum/o, + PV_LINK => qr/$RXname \s+ [.NPCAMS ]*/ox, + VME_IO => qr/\# (?: \s* [CS] \s* $RXdex)* \s* (?: @ .*)?/ox, + CAMAC_IO => qr/\# (?: \s* [BCNAF] \s* $RXdex)* \s* (?: @ .*)?/ox, + RF_IO => qr/\# (?: \s* [RMDE] \s* $RXdex)*/ox, + AB_IO => qr/\# (?: \s* [LACS] \s* $RXdex)* \s* (?: @ .*)?/ox, + GPIB_IO => qr/\# (?: \s* [LA] \s* $RXdex)* \s* (?: @ .*)?/ox, + BITBUS_IO => qr/\# (?: \s* [LNPS] \s* $RXdex)* \s* (?: @ .*)?/ox, + BBGPIB_IO => qr/\# (?: \s* [LBG] \s* $RXdex)* \s* (?: @ .*)?/ox, + VXI_IO => qr/\# (?: \s* [VCS] \s* $RXdex)* \s* (?: @ .*)?/ox, + INST_IO => qr/@.*/ +); + +sub init { + my ($this, $link_type, $dset, $choice) = @_; + dieContext("Unknown link type '$link_type', valid types are:", + sort keys %link_types) unless exists $link_types{$link_type}; + $this->SUPER::init($dset, "DSET name"); + $this->{LINK_TYPE} = $link_type; + $this->{CHOICE} = unquote($choice); + return $this; +} + +sub link_type { + return shift->{LINK_TYPE}; +} + +sub choice { + return shift->{CHOICE}; +} + +sub legal_addr { + my $this = shift; + my $addr = unquote(shift); + my $rx = $link_types{$this->{LINK_TYPE}}; + return $addr =~ m/^ $rx $/x; +} + +1; diff --git a/src/dbHost/DBD/Driver.pm b/src/dbHost/DBD/Driver.pm new file mode 100644 index 000000000..8cee4d05e --- /dev/null +++ b/src/dbHost/DBD/Driver.pm @@ -0,0 +1,9 @@ +package DBD::Driver; +use DBD::Util; +@ISA = qw(DBD::Util); + +sub init { + return shift->SUPER::init(shift, "driver entry table name"); +} + +1; diff --git a/src/dbHost/DBD/Function.pm b/src/dbHost/DBD/Function.pm new file mode 100644 index 000000000..ce014b585 --- /dev/null +++ b/src/dbHost/DBD/Function.pm @@ -0,0 +1,9 @@ +package DBD::Function; +@ISA = qw(DBD::Util); + +sub init { + return shift->SUPER::init(shift, "function name"); +} + +1; + diff --git a/src/dbHost/DBD/Menu.pm b/src/dbHost/DBD/Menu.pm new file mode 100644 index 000000000..8ae4291ae --- /dev/null +++ b/src/dbHost/DBD/Menu.pm @@ -0,0 +1,40 @@ +package DBD::Menu; +use DBD::Util; +@ISA = qw(DBD::Util); + +sub init { + my ($this, $name) = @_; + $this->SUPER::init($name, "menu name"); + $this->{CHOICES} = []; + $this->{CHOICE_INDEX} = {}; + return $this; +} + +sub add_choice { + my ($this, $name, $value) = @_; + $name = identifier($name, "Choice name"); + $value = unquote($value, "Choice value"); + foreach $pair ($this->choices) { + dieContext("Duplicate choice name") if ($pair->[0] eq $name); + dieContext("Duplicate choice string") if ($pair->[1] eq $value); + } + push @{$this->{CHOICES}}, [$name, $value]; + $this->{CHOICE_INDEX}->{$value} = $name; +} + +sub choices { + return @{shift->{CHOICES}}; +} + +sub choice { + my ($this, $idx) = @_; + return $this->{CHOICES}[$idx]; +} + +sub legal_choice { + my $this = shift; + my $value = unquote(shift); + return exists $this->{CHOICE_INDEX}->{$value}; +} + +1; diff --git a/src/dbHost/DBD/Recfield.pm b/src/dbHost/DBD/Recfield.pm new file mode 100644 index 000000000..81c0e410d --- /dev/null +++ b/src/dbHost/DBD/Recfield.pm @@ -0,0 +1,96 @@ +package DBD::Recfield; +use DBD::Util; +@ISA = qw(DBD::Util); + +# 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// +); + +# 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 +); + +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->{ATTRIBUTES} = {}; + return $this; +} + +sub 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->{ATTRIBUTES}->{$attr} = $value; +} + +sub attributes { + return shift->{ATTRIBUTES}; +} + +sub attribute { + 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; +} + +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? +} + +1; diff --git a/src/dbHost/DBD/Recordtype.pm b/src/dbHost/DBD/Recordtype.pm new file mode 100644 index 000000000..c505395e6 --- /dev/null +++ b/src/dbHost/DBD/Recordtype.pm @@ -0,0 +1,75 @@ +package DBD::Recordtype; +use DBD::Util; +@ISA = qw(DBD::Util); + +use Carp; + +sub init { + my $this = shift; + $this->SUPER::init(@_); + $this->{FIELDS} = []; # Ordered list + $this->{FIELD_INDEX} = {}; # Indexed by name + $this->{DEVICES} = []; # Ordered list + $this->{DEVICE_INDEX} = {}; # Indexed by choice + return $this; +} + +sub add_field { + my ($this, $field) = @_; + confess "Not a DBD::Recfield" unless $field->isa('DBD::Recfield'); + my $field_name = $field->name; + dieContext("Duplicate field name '$field_name'") + if exists $this->{FIELD_INDEX}->{$field_name}; + $field->check_valid; + push $this->{FIELDS}, $field; + $this->{FIELD_INDEX}->{$field_name} = $field; +} + +sub fields { + return shift->{FIELDS}; +} + +sub field_names { # In their original order... + my $this = shift; + my @names = (); + foreach ($this->fields) { + push @names, $_->name + } + return @names; +} + +sub field { + my ($this, $field) = @_; + return $this->{FIELD_INDEX}->{$field}; +} + +sub add_device { + my ($this, $device) = @_; + confess "Not a DBD::Device" unless $device->isa('DBD::Device'); + my $choice = $device->choice; + if (exists $this->{DEVICE_INDEX}->{$choice}) { + my @warning = ("Duplicate device type '$choice'"); + my $old = $this->{DEVICE_INDEX}->{$choice}; + push @warning, "Link types differ" + if ($old->link_type ne $device->link_type); + push @warning, "DSETs differ" + if ($old->name ne $device->name); + warnContext @warning; + return; + } + $device->check_valid; + push $this->{DEVICES}, $device; + $this->{DEVICE_INDEX}->{$choice} = $device; +} + +sub devices { + my $this = shift; + return $this->{DEVICES}; +} + +sub device { + my ($this, $choice) = @_; + return $this->{DEVICE_INDEX}->{$choice}; +} + +1; diff --git a/src/dbHost/DBD/Registrar.pm b/src/dbHost/DBD/Registrar.pm new file mode 100644 index 000000000..0eefb98fd --- /dev/null +++ b/src/dbHost/DBD/Registrar.pm @@ -0,0 +1,10 @@ +package DBD::Registrar; +@ISA = qw(DBD::Util); + +sub init { + return shift->SUPER::init(shift, "registrar function name"); +} + + +1; + diff --git a/src/dbHost/DBD/Util.pm b/src/dbHost/DBD/Util.pm new file mode 100644 index 000000000..54ee6e435 --- /dev/null +++ b/src/dbHost/DBD/Util.pm @@ -0,0 +1,85 @@ +package DBD::Util; + +use Carp; + +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(&pushContext &popContext &dieContext &identifier &unquote + $RXident $RXname $RXuint $RXint $RXdex $RXnum $RXdqs $RXsqs $RXstr); + + +our $RXident = qr/[a-zA-Z][a-zA-Z0-9_]*/; +our $RXname = qr/[a-zA-Z0-9_\-:.<>;]+/; +our $RXhex = qr/ (?: 0 [xX] [0-9A-Fa-f]+ ) /x; +our $RXuint = qr/ \d+ /x; +our $RXint = qr/ -? $RXuint /ox; +our $RXdex = qr/ ( $RXhex | $RXuint ) /x; +our $RXnum = qr/-? (?: \d+ ) | (?: \d* \. \d+ ) (?: [eE] [-+]? \d+ )?/x; +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; +} + +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 warnContext { + my ($msg) = join "\n\t", @_; + print "$msg\n" if $msg; + print "Context: ", join(' in ', @context), "\n"; +} + +sub unquote { + my ($string) = @_; + $string =~ m/^"(.*)"$/o and $string = $1; + return $string; +} + +sub identifier { + my $id = unquote(shift); + 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."); + return $id; +} + +sub new { + 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; +} + +sub name { + return shift->{NAME}; +} + +1; diff --git a/src/dbHost/DBD/Variable.pm b/src/dbHost/DBD/Variable.pm new file mode 100644 index 000000000..2791bb4ed --- /dev/null +++ b/src/dbHost/DBD/Variable.pm @@ -0,0 +1,27 @@ +package DBD::Variable; +use DBD::Util; +@ISA = qw(DBD::Util); + +my %var_types = ("int" => 1, "double" => 1); + +sub init { + my ($this, $name, $type) = @_; + if (defined $type) { + $type = unquote($type); + } else { + $type = "int"; + } + exists $var_types{$type} or + dieContext("Unknown variable type '$type', valid types are:", + sort keys %var_types); + $this->SUPER::init($name, "variable name"); + $this->{VAR_TYPE} = $type; + return $this; +} + +sub var_type { + my $this = shift; + return $this->{VAR_TYPE}; +} + +1; From b20cf681aec332f1ea7bbbc4d033afef5d6187f5 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 15:47:58 -0500 Subject: [PATCH 03/32] 2004-06-04: Added individual object tests. --- src/dbHost/DBD/Function.pm | 1 + src/dbHost/DBD/Registrar.pm | 1 + src/dbHost/test/Breaktable.pl | 19 +++++++++++++++++++ src/dbHost/test/Device.pl | 30 ++++++++++++++++++++++++++++++ src/dbHost/test/Driver.pl | 10 ++++++++++ src/dbHost/test/Function.pl | 10 ++++++++++ src/dbHost/test/Menu.pl | 23 +++++++++++++++++++++++ src/dbHost/test/Recfield.pl | 16 ++++++++++++++++ src/dbHost/test/Registrar.pl | 10 ++++++++++ src/dbHost/test/Util.pl | 8 ++++++++ src/dbHost/test/Variable.pl | 12 ++++++++++++ 11 files changed, 140 insertions(+) create mode 100644 src/dbHost/test/Breaktable.pl create mode 100644 src/dbHost/test/Device.pl create mode 100644 src/dbHost/test/Driver.pl create mode 100644 src/dbHost/test/Function.pl create mode 100644 src/dbHost/test/Menu.pl create mode 100644 src/dbHost/test/Recfield.pl create mode 100644 src/dbHost/test/Registrar.pl create mode 100644 src/dbHost/test/Util.pl create mode 100644 src/dbHost/test/Variable.pl diff --git a/src/dbHost/DBD/Function.pm b/src/dbHost/DBD/Function.pm index ce014b585..f90062d6c 100644 --- a/src/dbHost/DBD/Function.pm +++ b/src/dbHost/DBD/Function.pm @@ -1,4 +1,5 @@ package DBD::Function; +use DBD::Util; @ISA = qw(DBD::Util); sub init { diff --git a/src/dbHost/DBD/Registrar.pm b/src/dbHost/DBD/Registrar.pm index 0eefb98fd..d3c120311 100644 --- a/src/dbHost/DBD/Registrar.pm +++ b/src/dbHost/DBD/Registrar.pm @@ -1,4 +1,5 @@ package DBD::Registrar; +use DBD::Util; @ISA = qw(DBD::Util); sub init { diff --git a/src/dbHost/test/Breaktable.pl b/src/dbHost/test/Breaktable.pl new file mode 100644 index 000000000..09285491a --- /dev/null +++ b/src/dbHost/test/Breaktable.pl @@ -0,0 +1,19 @@ +#!/usr/bin/perl + +use Test::More tests => 9; + +use DBD::Breaktable; + +my $bpt = DBD::Breaktable->new('test'); +isa_ok $bpt, 'DBD::Breaktable'; +is $bpt->name, 'test', 'Breakpoint table name'; +is $bpt->points, 0, 'Points == zero'; +$bpt->add_point(0, 0.5); +is $bpt->points, 1, 'First point added'; +is_deeply $bpt->point(0), [0, 0.5], 'First point correct'; +$bpt->add_point(1, 1.5); +is $bpt->points, 2, 'Second point added'; +is_deeply $bpt->point(0), [0, 0.5], 'First point still correct'; +is_deeply $bpt->point(1), [1, 1.5], 'Second point correct'; +is_deeply $bpt->point(2), undef, 'Third point undefined'; + diff --git a/src/dbHost/test/Device.pl b/src/dbHost/test/Device.pl new file mode 100644 index 000000000..0b960d2a5 --- /dev/null +++ b/src/dbHost/test/Device.pl @@ -0,0 +1,30 @@ +#!/usr/bin/perl + +use Test::More tests => 16; + +use DBD::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'; +is $dev->choice, 'Device', 'Choice string'; +ok $dev->legal_addr('#C0xFEED S123 @xxx'), 'Address legal'; +my %dev_addrs = ( + CONSTANT => '12345', + PV_LINK => 'Any:Record.NAME CPP.MS', + VME_IO => '# C1 S2 @Anything', + CAMAC_IO => '# B1 C2 N3 A4 F5 @Anything', + RF_IO => '# R1 M2 D3 E4', + AB_IO => '# L1 A2 C3 S4 @Anything', + GPIB_IO => '# L1 A2 @Anything', + BITBUS_IO => '# L1 N2 P3 S4 @Anything', + BBGPIB_IO => '# L1 B2 G3 @Anything', + VXI_IO => '# V1 C2 S3 @Anything', + INST_IO => '@Anything' +); +while (my ($link, $addr) = each(%dev_addrs)) { + $dev->init($link, 'test', '"Device"'); + ok $dev->legal_addr($addr), "$link address"; +} + diff --git a/src/dbHost/test/Driver.pl b/src/dbHost/test/Driver.pl new file mode 100644 index 000000000..36f065996 --- /dev/null +++ b/src/dbHost/test/Driver.pl @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +use Test::More tests => 2; + +use DBD::Driver; + +my $drv = DBD::Driver->new('test'); +isa_ok $drv, 'DBD::Driver'; +is $drv->name, 'test', 'Driver name'; + diff --git a/src/dbHost/test/Function.pl b/src/dbHost/test/Function.pl new file mode 100644 index 000000000..7df69e44f --- /dev/null +++ b/src/dbHost/test/Function.pl @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +use Test::More tests => 2; + +use DBD::Function; + +my $func = DBD::Function->new('test'); +isa_ok $func, 'DBD::Function'; +is $func->name, 'test', 'Function name'; + diff --git a/src/dbHost/test/Menu.pl b/src/dbHost/test/Menu.pl new file mode 100644 index 000000000..635c9a6ec --- /dev/null +++ b/src/dbHost/test/Menu.pl @@ -0,0 +1,23 @@ +#!/usr/bin/perl + +use Test::More tests => 13; + +use DBD::Menu; + +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"'); +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"'); +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'; +ok $menu->legal_choice('Choice 2'), 'Second choice legal'; +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'; + diff --git a/src/dbHost/test/Recfield.pl b/src/dbHost/test/Recfield.pl new file mode 100644 index 000000000..8807f777a --- /dev/null +++ b/src/dbHost/test/Recfield.pl @@ -0,0 +1,16 @@ +#!/usr/bin/perl + +use Test::More tests => 7; + +use DBD::Recfield; + +my $fld = DBD::Recfield->new('test', 'DBF_LONG'); +isa_ok $fld, 'DBD::Recfield'; +is $fld->name, 'test', 'Field name'; +is $fld->dbf_type, 'DBF_LONG', 'Field type'; +is keys %{$fld->attributes}, 0, 'No attributes'; +ok $fld->legal_value("-1234"), 'Legal long value'; +$fld->add_attribute("asl", "ASL0"); +is keys %{$fld->attributes}, 1, "Attribute added"; +$fld->check_valid; +is $fld->attribute("asl"), "ASL0", "Attribute value"; diff --git a/src/dbHost/test/Registrar.pl b/src/dbHost/test/Registrar.pl new file mode 100644 index 000000000..326cf0064 --- /dev/null +++ b/src/dbHost/test/Registrar.pl @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +use Test::More tests => 2; + +use DBD::Registrar; + +my $reg = DBD::Registrar->new('test'); +isa_ok $reg, 'DBD::Registrar'; +is $reg->name, 'test', 'Registrar name'; + diff --git a/src/dbHost/test/Util.pl b/src/dbHost/test/Util.pl new file mode 100644 index 000000000..7de8c887e --- /dev/null +++ b/src/dbHost/test/Util.pl @@ -0,0 +1,8 @@ +#!/usr/bin/perl + +use Test::More tests => 2; + +use DBD::Util; + +is unquote('"x"'), 'x', '"unquote"'; +isnt unquote('x""'), 'x', 'unquote""'; diff --git a/src/dbHost/test/Variable.pl b/src/dbHost/test/Variable.pl new file mode 100644 index 000000000..84f67b0d8 --- /dev/null +++ b/src/dbHost/test/Variable.pl @@ -0,0 +1,12 @@ +#!/usr/bin/perl + +use Test::More tests => 4; + +use DBD::Variable; + +my $ivar = DBD::Variable->new('test'); +isa_ok $ivar, 'DBD::Variable'; +is $ivar->name, 'test', 'Variable name'; +is $ivar->var_type, 'int', 'variable defaults to int'; +my $dvar = DBD::Variable->new('test', 'double'); +is $dvar->var_type, 'double', 'double variable'; From 680e05c2c2b51f4b5ce1d083767c241a416d1d6c Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 15:48:50 -0500 Subject: [PATCH 04/32] 2004-06-23: Fixed various things, added Recordtype and global DBD object tests. --- src/dbHost/DBD.pm | 89 ++++++++++++++++++++++------------- src/dbHost/DBD/Breaktable.pm | 8 ++-- src/dbHost/DBD/Menu.pm | 8 ++-- src/dbHost/DBD/Recfield.pm | 6 +-- src/dbHost/DBD/Recordtype.pm | 23 +++++---- src/dbHost/Readfile.pm | 9 +++- src/dbHost/test/DBD.pl | 57 ++++++++++++++++++++++ src/dbHost/test/Recordtype.pl | 45 ++++++++++++++++++ 8 files changed, 188 insertions(+), 57 deletions(-) create mode 100644 src/dbHost/test/DBD.pl create mode 100644 src/dbHost/test/Recordtype.pl diff --git a/src/dbHost/DBD.pm b/src/dbHost/DBD.pm index 1cf82cc8a..f63541cc1 100644 --- a/src/dbHost/DBD.pm +++ b/src/dbHost/DBD.pm @@ -1,7 +1,7 @@ package DBD; +use DBD::Util; use DBD::Breaktable; -use DBD::Device; use DBD::Driver; use DBD::Menu; use DBD::Recordtype; @@ -10,48 +10,73 @@ use DBD::Registrar; use DBD::Function; use DBD::Variable; +use Carp; + sub new { my $proto = shift; my $class = ref($proto) || $proto; my $this = { - BREAKTABLES => {}, - DEVICES => {}, - DRIVERS => {}, - MENUS => {}, - RECORDTYPES => {}, - REGISTRARS => {}, - FUNCTIONS => {}, - VARIABLES => {} + 'DBD::Breaktable' => {}, + 'DBD::Driver' => {}, + 'DBD::Function' => {}, + 'DBD::Menu' => {}, + 'DBD::Recordtype' => {}, + 'DBD::Registrar' => {}, + 'DBD::Variable' => {} }; bless $this, $class; return $this; } -sub add_breaktable { -} - -sub add_driver { -} - -sub add_menu { -} - -sub add_recordtype { -} - -sub add_registrar { -} - -sub add_function { -} - -sub add_variable { +sub add { my ($this, $obj) = @_; - confess "Not a DBD::Variable" unless $obj->isa('DBD::Variable'); + 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 variable '$obj_name'") - if exists $this->{VARIABLES}->{$obj_name}; - $this->{VARIABLES}->{$obj_name} = $obj; + dieContext("Duplicate name '$obj_name'") + if exists $this->{$obj_class}->{$obj_name}; + $this->{$obj_class}->{$obj_name} = $obj; +} + +sub breaktables { + return %{shift->{'DBD::Breaktable'}}; +} + +sub drivers { + return %{shift->{'DBD::Driver'}}; +} + +sub functions { + return %{shift->{'DBD::Function'}}; +} + +sub menus { + return %{shift->{'DBD::Menu'}}; +} +sub menu { + my ($this, $menu_name) = @_; + return $this->{'DBD::Menu'}->{$menu_name}; +} + +sub recordtypes { + return %{shift->{'DBD::Recordtype'}}; +} +sub recordtype { + my ($this, $rtyp_name) = @_; + return $this->{'DBD::Recordtype'}->{$rtyp_name}; +} + +sub registrars { + return %{shift->{'DBD::Registrar'}}; +} + +sub variables { + return %{shift->{'DBD::Variable'}}; } 1; diff --git a/src/dbHost/DBD/Breaktable.pm b/src/dbHost/DBD/Breaktable.pm index b36067aa1..12ae449b5 100644 --- a/src/dbHost/DBD/Breaktable.pm +++ b/src/dbHost/DBD/Breaktable.pm @@ -7,7 +7,7 @@ use Carp; sub init { my ($this, $name) = @_; $this->SUPER::init($name, "breakpoint table name"); - $this->{POINTS} = []; + $this->{POINT_LIST} = []; return $this; } @@ -17,16 +17,16 @@ sub add_point { $raw = unquote($raw); confess "Engineering value undefined!" unless defined $eng; $eng = unquote($eng); - push @{$this->{POINTS}}, [$raw, $eng]; + push @{$this->{POINT_LIST}}, [$raw, $eng]; } sub points { - return @{shift->{POINTS}}; + return @{shift->{POINT_LIST}}; } sub point { my ($this, $idx) = @_; - return $this->{POINTS}[$idx]; + return $this->{POINT_LIST}[$idx]; } 1; diff --git a/src/dbHost/DBD/Menu.pm b/src/dbHost/DBD/Menu.pm index 8ae4291ae..fe602dcbf 100644 --- a/src/dbHost/DBD/Menu.pm +++ b/src/dbHost/DBD/Menu.pm @@ -5,7 +5,7 @@ use DBD::Util; sub init { my ($this, $name) = @_; $this->SUPER::init($name, "menu name"); - $this->{CHOICES} = []; + $this->{CHOICE_LIST} = []; $this->{CHOICE_INDEX} = {}; return $this; } @@ -18,17 +18,17 @@ sub add_choice { dieContext("Duplicate choice name") if ($pair->[0] eq $name); dieContext("Duplicate choice string") if ($pair->[1] eq $value); } - push @{$this->{CHOICES}}, [$name, $value]; + push @{$this->{CHOICE_LIST}}, [$name, $value]; $this->{CHOICE_INDEX}->{$value} = $name; } sub choices { - return @{shift->{CHOICES}}; + return @{shift->{CHOICE_LIST}}; } sub choice { my ($this, $idx) = @_; - return $this->{CHOICES}[$idx]; + return $this->{CHOICE_LIST}[$idx]; } sub legal_choice { diff --git a/src/dbHost/DBD/Recfield.pm b/src/dbHost/DBD/Recfield.pm index 81c0e410d..16eba16e5 100644 --- a/src/dbHost/DBD/Recfield.pm +++ b/src/dbHost/DBD/Recfield.pm @@ -45,7 +45,7 @@ sub init { exists $field_types{$type} or dieContext("Illegal field type '$type', ". "valid field types are:", sort keys %field_types); $this->{DBF_TYPE} = $type; - $this->{ATTRIBUTES} = {}; + $this->{ATTR_INDEX} = {}; return $this; } @@ -62,11 +62,11 @@ sub add_attribute { unless exists $field_attrs{$attr}; dieContext("Bad value '$value' for field '$attr' attribute") unless $value =~ m/^ $field_attrs{$attr} $/x; - $this->{ATTRIBUTES}->{$attr} = $value; + $this->{ATTR_INDEX}->{$attr} = $value; } sub attributes { - return shift->{ATTRIBUTES}; + return shift->{ATTR_INDEX}; } sub attribute { diff --git a/src/dbHost/DBD/Recordtype.pm b/src/dbHost/DBD/Recordtype.pm index c505395e6..8160966a2 100644 --- a/src/dbHost/DBD/Recordtype.pm +++ b/src/dbHost/DBD/Recordtype.pm @@ -7,10 +7,10 @@ use Carp; sub init { my $this = shift; $this->SUPER::init(@_); - $this->{FIELDS} = []; # Ordered list - $this->{FIELD_INDEX} = {}; # Indexed by name - $this->{DEVICES} = []; # Ordered list - $this->{DEVICE_INDEX} = {}; # Indexed by choice + $this->{FIELD_LIST} = []; + $this->{FIELD_INDEX} = {}; + $this->{DEVICE_LIST} = []; + $this->{DEVICE_INDEX} = {}; return $this; } @@ -21,12 +21,12 @@ sub add_field { dieContext("Duplicate field name '$field_name'") if exists $this->{FIELD_INDEX}->{$field_name}; $field->check_valid; - push $this->{FIELDS}, $field; + push @{$this->{FIELD_LIST}}, $field; $this->{FIELD_INDEX}->{$field_name} = $field; } sub fields { - return shift->{FIELDS}; + return @{shift->{FIELD_LIST}}; } sub field_names { # In their original order... @@ -39,8 +39,8 @@ sub field_names { # In their original order... } sub field { - my ($this, $field) = @_; - return $this->{FIELD_INDEX}->{$field}; + my ($this, $field_name) = @_; + return $this->{FIELD_INDEX}->{$field_name}; } sub add_device { @@ -54,17 +54,16 @@ sub add_device { if ($old->link_type ne $device->link_type); push @warning, "DSETs differ" if ($old->name ne $device->name); - warnContext @warning; + warnContext(@warning); return; } - $device->check_valid; - push $this->{DEVICES}, $device; + push @{$this->{DEVICE_LIST}}, $device; $this->{DEVICE_INDEX}->{$choice} = $device; } sub devices { my $this = shift; - return $this->{DEVICES}; + return @{$this->{DEVICE_LIST}}; } sub device { diff --git a/src/dbHost/Readfile.pm b/src/dbHost/Readfile.pm index 755c030b6..9b5efdf04 100644 --- a/src/dbHost/Readfile.pm +++ b/src/dbHost/Readfile.pm @@ -34,9 +34,11 @@ sub slurp { } sub macval { - my ($macro, $Rmacros) = @_; + 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; @@ -47,7 +49,10 @@ sub expandMacros { my ($Rmacros, @input) = @_; my @output; foreach (@input) { - s/\$\((\w+)\)/&macval($1, $Rmacros)/eg unless /^\s*#/; + # FIXME: This is wrong, use Text::Balanced, starting from: + # @result = extract_bracketed($_, '{}()\'"', '\s*\$') + s/ \$ \( (\w+) (?: = (.*) )? \) / &macval($1, $2, $Rmacros) /egx + unless /^\s*#/; push @output, $_; } return @output; diff --git a/src/dbHost/test/DBD.pl b/src/dbHost/test/DBD.pl new file mode 100644 index 000000000..fb76f95d9 --- /dev/null +++ b/src/dbHost/test/DBD.pl @@ -0,0 +1,57 @@ +#!/usr/bin/perl + +use Test::More tests => 18; + +use DBD; + +my $dbd = DBD->new; +isa_ok $dbd, 'DBD'; + +is keys %{$dbd->breaktables}, 0, 'No breaktables yet'; +my $reg = DBD::Breaktable->new('Brighton'); +$dbd->add($reg); +my %regs = $dbd->breaktables; +is_deeply \%regs, {Brighton => $reg}, 'Added breaktable'; + +is keys %{$dbd->drivers}, 0, 'No drivers yet'; +my $reg = DBD::Driver->new('Danforth'); +$dbd->add($reg); +my %regs = $dbd->drivers; +is_deeply \%regs, {Danforth => $reg}, 'Added driver'; + +is keys %{$dbd->functions}, 0, 'No functions yet'; +my $reg = DBD::Function->new('Frank'); +$dbd->add($reg); +my %regs = $dbd->functions; +is_deeply \%regs, {Frank => $reg}, 'Added function'; + +is keys %{$dbd->menus}, 0, 'No menus yet'; +my $menu = DBD::Menu->new('Mango'); +$dbd->add($menu); +my %menus = $dbd->menus; +is_deeply \%menus, {Mango => $menu}, 'Added menu'; +is $dbd->menu('Mango'), $menu, 'Named menu'; + +is keys %{$dbd->recordtypes}, 0, 'No recordtypes yet'; +my $rtyp = DBD::Recordtype->new('Rita'); +$dbd->add($rtyp); +my %rtypes = $dbd->recordtypes; +is_deeply \%rtypes, {Rita => $rtyp}, 'Added recordtype'; +is $dbd->recordtype('Rita'), $rtyp, 'Named recordtype'; + +is keys %{$dbd->registrars}, 0, 'No registrars yet'; +my $reg = DBD::Registrar->new('Reggie'); +$dbd->add($reg); +my %regs = $dbd->registrars; +is_deeply \%regs, {Reggie => $reg}, 'Added registrar'; + +is keys %{$dbd->variables}, 0, 'No variables yet'; +my $ivar = DBD::Variable->new('IntVar'); +my $dvar = DBD::Variable->new('DblVar', 'double'); +$dbd->add($ivar); +my %vars = $dbd->variables; +is_deeply \%vars, {IntVar => $ivar}, 'First variable'; +$dbd->add($dvar); +%vars = $dbd->variables; +is_deeply \%vars, {IntVar => $ivar, DblVar => $dvar}, 'Second variable'; + diff --git a/src/dbHost/test/Recordtype.pl b/src/dbHost/test/Recordtype.pl new file mode 100644 index 000000000..d4d47d6c6 --- /dev/null +++ b/src/dbHost/test/Recordtype.pl @@ -0,0 +1,45 @@ +#!/usr/bin/perl + +use Test::More tests => 12; + +use DBD::Recordtype; +use DBD::Recfield; +use DBD::Device; + +my $rtyp = DBD::Recordtype->new('test'); +isa_ok $rtyp, 'DBD::Recordtype'; +is $rtyp->name, 'test', 'Record name'; +is $rtyp->fields, 0, 'No fields yet'; + +my $fld1 = DBD::Recfield->new('NAME', 'DBF_STRING'); +$fld1->add_attribute("size", "41"); +$fld1->check_valid; + +my $fld2 = DBD::Recfield->new('DTYP', 'DBF_DEVICE'); +$fld2->check_valid; + +$rtyp->add_field($fld1); +is $rtyp->fields, 1, 'First field added'; + +$rtyp->add_field($fld2); +is $rtyp->fields, 2, 'Second field added'; + +my @fields = $rtyp->fields; +is_deeply \@fields, [$fld1, $fld2], 'Field list'; + +my @names = $rtyp->field_names; +is_deeply \@names, ['NAME', 'DTYP'], 'Field name list'; + +is $rtyp->field('NAME'), $fld1, 'Field name lookup'; + +is $rtyp->devices, 0, 'No devices yet'; + +my $dev1 = DBD::Device->new('INST_IO', 'testDset', 'test device'); +$rtyp->add_device($dev1); +is $rtyp->devices, 1, 'First device added'; + +my @devices = $rtyp->devices; +is_deeply \@devices, [$dev1], 'Device list'; + +is $rtyp->device('test device'), $dev1, 'Device name lookup'; + From 86c12943bc989c29854279c069946e563bb95971 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 15:50:43 -0500 Subject: [PATCH 05/32] 2004-07-06: Implementation of libCom's macLib for perl code. --- src/dbHost/macLib.pm | 238 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 238 insertions(+) create mode 100644 src/dbHost/macLib.pm diff --git a/src/dbHost/macLib.pm b/src/dbHost/macLib.pm new file mode 100644 index 000000000..b5f3a2294 --- /dev/null +++ b/src/dbHost/macLib.pm @@ -0,0 +1,238 @@ +package macLib::entry; + +sub new ($$) { + my $class = shift; + my $this = { + name => shift, + type => shift, + raw => '', + val => '', + visited => 0, + error => 0, + }; + bless $this, $class; + return $this; +} + +sub report ($) { + my ($this) = @_; + return unless defined $this->{raw}; + printf "%1s %-16s %-16s %s\n", + ($this->{error} ? '*' : ' '), $this->{name}, $this->{raw}, $this->{val}; +} + + +package macLib; + +use Carp; + +sub new ($%) { + my ($proto, %values) = @_; + my $class = ref($proto) || $proto; + my $this = { + dirty => 0, + noWarn => 0, + macros => [{}], # [0] is current scope, [1] is parent etc. + }; + bless $this, $class; + $this->installHash(%values); + 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}) { + if (!defined $raw) { + delete $this->{macros}[0]{$name}; + } else { + $this->{macros}[0]{$name}{raw} = $raw; + } + } else { + my $entry = macLib::entry->new($name, 'macro'); + $entry->{raw} = $raw; + $this->{macros}[0]{$name} = $entry; + } + $this->{dirty} = 1; +} + +sub installHash ($%) { + my ($this, %values) = @_; + foreach $key (keys %values) { + $this->putValue($key, $values{$key}); + } +} + +sub installMacros ($$) { + my $this = shift; + $_ = shift; + my $eos = 0; + until ($eos ||= m/\G \z/xgc) { + 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) { + if (m/\G , /xgc) { last; } + elsif (m/\G ' ( ( [^'] | \\ ' )* ) ' /xgc) { $val .= $1; } + elsif (m/\G " ( ( [^"] | \\ " )* ) " /xgc) { $val .= $1; } + elsif (m/\G \\ ( . ) /xgc) { $val .= $1; } + elsif (m/\G ( . ) /xgc) { $val .= $1; } + else { die "How did I get here?"; } + } + $this->putValue($name, $val); + } elsif (m/\G , /xgc or ($eos ||= m/\G \z/xgc)) { + $this->putValue($name, undef); + } else { + die "How did I get here?"; + } + } elsif (m/\G ( .* )/xgc) { + croak "Can't find a macro definition in '$1'"; + } else { + last; + } + } +} + +sub pushScope ($) { + my ($this) = @_; + push @{$this->{macros}}, {}; +} + +sub popScope ($) { + my ($this) = @_; + pop @{$this->{macros}}; +} + +sub reportMacros ($) { + my ($this) = @_; + $this->_expand; + print "Macro report\n"; + foreach my $scope (@{$this->{macros}}) { + foreach my $name (keys %{$scope}) { + my $entry = $scope->{$name}; + $entry->report; + } + } +} + + +# Private routines, not intended for public use + +sub _expand ($) { + my ($this) = @_; + return unless $this->{dirty}; + foreach my $scope (@{$this->{macros}}) { + foreach my $name (keys %{$scope}) { + my $entry = $scope->{$name}; + $entry->{val} = $this->_translate($entry, 1, $entry->{raw}); + } + } + $this->{dirty} = 0; +} + +sub _lookup ($$$$$) { + my ($this, $name) = @_; + foreach my $scope (@{$this->{macros}}) { + if (exists $scope->{$name}) { + return undef # Macro marked as deleted + unless defined $scope->{$name}{raw}; + return $scope->{$name}; + } + } + return undef; +} + +sub _translate ($$$$) { + my ($this, $entry, $level, $str) = @_; + return $this->_trans($entry, $level, '', \$str); +} + +sub _trans ($$$$$) { + my ($this, $entry, $level, $term, $R) = @_; + return $$R + if ($$R =~ m/\A [^\$]* \Z/x); # Short-circuit if no macros + my $quote = 0; + my $val; + until ($$R =~ m/\G \z/xgc) { + if ($term and ($$R =~ m/\G (?= [$term] ) /xgc)) { + last; + } + if ($$R =~ m/\G \$ ( [({] ) /xgc) { + my $macEnd = $1; + $macEnd =~ tr/({/)}/; + my $name2 = $this->_trans($entry, $level+1, "=$macEnd", $R); + my $entry2 = $this->_lookup($name2); + if (!defined $entry2) { # Macro not found + if ($$R =~ m/\G = /xgc) { # Use default value given + $val .= $this->_trans($entry, $level+1, $macEnd, $R); + } else { + unless ($this->{noWarn}) { + $entry->{error} = 1; + printf STDERR "macLib: macro '%s' is undefined (expanding %s '%s')\n", + $name2, $entry->{type}, $entry->{name}; + } + $val .= "\$($name2)"; + } + $$R =~ m/\G [$macEnd] /xgc; # Discard close bracket + } else { # Macro found + if ($entry2->{visited}) { + $entry->{error} = 1; + printf STDERR "macLib: %s '%s' is recursive (expanding %s '%s')\n", + $entry->{type}, $entry->{name}, $entry2->{type}, $entry2->{name}; + $val .= "\$($name)"; + } else { + if ($$R =~ m/\G = /xgc) { # Discard default value + local $this->{noWarn} = 1; # Temporarily kill warnings + $this->_trans($entry, $level+1, $macEnd, $R); + } + $$R =~ m/\G [$macEnd] /xgc; # Discard close bracket + if ($this->{dirty}) { # Translate raw value + $entry2->{visited} = 1; + $val .= $this->_trans($entry, $level+1, '', \$entry2->{raw}); + $entry2->{visited} = 0; + } else { + $val .= $entry2->{val}; # Here's one I made earlier... + } + } + } + } elsif ($level > 0) { # Discard quotes and escapes + if ($quote and $$R =~ m/\G $quote /xgc) { + $quote = 0; + } elsif ($$R =~ m/\G ( ['"] ) /xgc) { + $quote = $1; + } elsif ($$R =~ m/\G \\? ( . ) /xgc) { + $val .= $1; + } else { + die "How did I get here?"; + } + } else { # Level 0 + if ($$R =~ m/\G \\ ( . ) /xgc) { + $val .= "\\$1"; + } elsif ($$R =~ m/\G ( [^\\\$'")}]* ) /xgc) { + $val .= $1; + } elsif ($$R =~ m/\G ( . ) /xgc) { + $val .= $1; + } else { + die "How did I get here?"; + } + } + } + return $val; +} + +1; From 42367731ef50edca50d561f0551de81e6889977a Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 15:52:36 -0500 Subject: [PATCH 06/32] 2004-07-08: Lots of development work, parser works. --- src/dbHost/DBD.pm | 74 +++--- src/dbHost/DBD/{Util.pm => Base.pm} | 56 +++-- src/dbHost/DBD/Breaktable.pm | 4 +- src/dbHost/DBD/Device.pm | 4 +- src/dbHost/DBD/Driver.pm | 4 +- src/dbHost/DBD/Function.pm | 4 +- src/dbHost/DBD/Menu.pm | 14 +- src/dbHost/DBD/Parser.pm | 192 +++++++++++++++ src/dbHost/DBD/Recfield.pm | 128 +++++----- src/dbHost/DBD/Recordtype.pm | 4 +- src/dbHost/DBD/Registrar.pm | 4 +- src/dbHost/DBD/Variable.pm | 4 +- src/dbHost/ReadDBD.pm | 350 --------------------------- src/dbHost/Readfile.pm | 30 +-- src/dbHost/dbExpand | 8 +- src/dbHost/dbToMenuH | 25 +- src/dbHost/dbdReport | 50 ++-- src/dbHost/macLib.pm | 65 ++--- src/dbHost/test/{Util.pl => Base.pl} | 2 +- src/dbHost/test/Menu.pl | 3 +- src/dbHost/test/macLib.pl | 69 ++++++ 21 files changed, 517 insertions(+), 577 deletions(-) rename src/dbHost/DBD/{Util.pm => Base.pm} (56%) create mode 100644 src/dbHost/DBD/Parser.pm delete mode 100644 src/dbHost/ReadDBD.pm rename src/dbHost/test/{Util.pl => Base.pl} (89%) create mode 100644 src/dbHost/test/macLib.pl 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'; + From 38bd72e67a49b38b4aae680524f72301669a1a9f Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 15:54:02 -0500 Subject: [PATCH 07/32] 2004-07-09: Progress! Added a class for each Recfield DBF_TYPE, use this to simplify conversion to C code. dbToRecordtypeH incomplete, but it outputs the record struct. 190 tests, 100% ok. --- src/dbHost/DBD/Base.pm | 28 +-- src/dbHost/DBD/Device.pm | 16 +- src/dbHost/DBD/Recfield.pm | 357 +++++++++++++++++++++++++++++++++-- src/dbHost/DBD/Recordtype.pm | 98 +++++----- src/dbHost/dbToMenuH | 4 +- src/dbHost/dbToRecordtypeH | 64 +++++++ src/dbHost/macLib.pm | 7 +- src/dbHost/test/DBD.pl | 34 ++-- src/dbHost/test/Recfield.pl | 115 +++++++++-- 9 files changed, 607 insertions(+), 116 deletions(-) create mode 100755 src/dbHost/dbToRecordtypeH diff --git a/src/dbHost/DBD/Base.pm b/src/dbHost/DBD/Base.pm index 8e703aabb..f65b99c4b 100644 --- a/src/dbHost/DBD/Base.pm +++ b/src/dbHost/DBD/Base.pm @@ -6,21 +6,23 @@ use Carp; require Exporter; @ISA = qw(Exporter); -@EXPORT = qw(&pushContext &popContext &dieContext &warnContext - &identifier &unquote &escapeCcomment &escapeCstring - $RXident $RXname $RXuint $RXint $RXdex $RXnum $RXdqs $RXsqs $RXstr); +@EXPORT = qw(&pushContext &popContext &dieContext &warnContext &identifier + &unquote &escapeCcomment &escapeCstring $RXident $RXname $RXuint $RXint + $RXhex $RXoct $RXuintx $RXintx $RXnum $RXdqs $RXsqs $RXstr); -our $RXident = qr/[a-zA-Z][a-zA-Z0-9_]*/; -our $RXname = qr/[a-zA-Z0-9_\-:.<>;]+/; -our $RXhex = qr/ (?: 0 [xX] [0-9A-Fa-f]+ ) /x; -our $RXuint = qr/ \d+ /x; -our $RXint = qr/ -? $RXuint /ox; -our $RXdex = qr/ ( $RXhex | $RXuint ) /x; -our $RXnum = qr/-? (?: \d+ ) | (?: \d* \. \d+ ) (?: [eE] [-+]? \d+ )?/x; -our $RXdqs = qr/" (?: [^"] | \\" )* "/x; -our $RXsqs = qr/' (?: [^'] | \\' )* '/x; -our $RXstr = qr/ ( $RXname | $RXnum | $RXdqs | $RXsqs ) /ox; +our $RXident = qr/ [a-zA-Z] [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; +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 $RXstr = qr/ ( $RXname | $RXnum | $RXdqs | $RXsqs ) /ox; our @context; diff --git a/src/dbHost/DBD/Device.pm b/src/dbHost/DBD/Device.pm index 1b7972450..bd60e0075 100644 --- a/src/dbHost/DBD/Device.pm +++ b/src/dbHost/DBD/Device.pm @@ -5,14 +5,14 @@ use DBD::Base; my %link_types = ( CONSTANT => qr/$RXnum/o, PV_LINK => qr/$RXname \s+ [.NPCAMS ]*/ox, - VME_IO => qr/\# (?: \s* [CS] \s* $RXdex)* \s* (?: @ .*)?/ox, - CAMAC_IO => qr/\# (?: \s* [BCNAF] \s* $RXdex)* \s* (?: @ .*)?/ox, - RF_IO => qr/\# (?: \s* [RMDE] \s* $RXdex)*/ox, - AB_IO => qr/\# (?: \s* [LACS] \s* $RXdex)* \s* (?: @ .*)?/ox, - GPIB_IO => qr/\# (?: \s* [LA] \s* $RXdex)* \s* (?: @ .*)?/ox, - BITBUS_IO => qr/\# (?: \s* [LNPS] \s* $RXdex)* \s* (?: @ .*)?/ox, - BBGPIB_IO => qr/\# (?: \s* [LBG] \s* $RXdex)* \s* (?: @ .*)?/ox, - VXI_IO => qr/\# (?: \s* [VCS] \s* $RXdex)* \s* (?: @ .*)?/ox, + VME_IO => qr/\# (?: \s* [CS] \s* $RXintx)* \s* (?: @ .*)?/ox, + CAMAC_IO => qr/\# (?: \s* [BCNAF] \s* $RXintx)* \s* (?: @ .*)?/ox, + RF_IO => qr/\# (?: \s* [RMDE] \s* $RXintx)*/ox, + AB_IO => qr/\# (?: \s* [LACS] \s* $RXintx)* \s* (?: @ .*)?/ox, + GPIB_IO => qr/\# (?: \s* [LA] \s* $RXintx)* \s* (?: @ .*)?/ox, + BITBUS_IO => qr/\# (?: \s* [LNPS] \s* $RXuintx)* \s* (?: @ .*)?/ox, + BBGPIB_IO => qr/\# (?: \s* [LBG] \s* $RXuintx)* \s* (?: @ .*)?/ox, + VXI_IO => qr/\# (?: \s* [VCS] \s* $RXintx)* \s* (?: @ .*)?/ox, INST_IO => qr/@.*/ ); diff --git a/src/dbHost/DBD/Recfield.pm b/src/dbHost/DBD/Recfield.pm index 3cb0c94c1..b1711c76e 100644 --- a/src/dbHost/DBD/Recfield.pm +++ b/src/dbHost/DBD/Recfield.pm @@ -5,12 +5,12 @@ use 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_CHAR => $RXintx, + DBF_UCHAR => $RXuintx, + DBF_SHORT => $RXintx, + DBF_USHORT => $RXuintx, + DBF_LONG => $RXintx, + DBF_ULONG => $RXuintx, DBF_FLOAT => $RXnum, DBF_DOUBLE => $RXnum, DBF_ENUM => qr/.*/, @@ -37,13 +37,22 @@ our %field_attrs = ( menu => qr/$RXident/o ); +sub new { + my ($class, $name, $type) = @_; + dieContext("Illegal field type '$type', valid field types are:", + sort keys %field_types) unless exists $field_types{$type}; + my $this = {}; + bless $this, "${class}::${type}"; + return $this->init($name, $type); +} + 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); + dieContext("Illegal field type '$type', valid field types are:", + sort keys %field_types) unless exists $field_types{$type}; $this->{DBF_TYPE} = $type; $this->{ATTR_INDEX} = {}; return $this; @@ -74,23 +83,333 @@ sub attribute { return $this->attributes->{$attr}; } -sub legal_value { - 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? +} + +# dieContext("Menu name missing for field '$name'") +# if ($this->dbf_type eq "DBF_MENU" and +# !defined($this->attribute("menu"))); + +sub toDeclaration { + my ($this, $ctype) = @_; + my $name = lc $this->name; + my $result = "$ctype $name;"; + my $prompt = $this->attribute('prompt'); + $result .= "\t/* $prompt */" if defined $prompt; + return $result; +} + + +################################################################################ + +package DBD::Recfield::DBF_STRING; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + my ($this, $value) = @_; + return (length $value < $this->attribute('size')); + # NB - we use '<' to allow space for the terminating nil byte +} + +sub check_valid { + my $this = shift; + dieContext("Size missing for DBF_STRING field '$name'") + unless exists $this->attributes->{'size'}; + $this->SUPER::check_valid; +} + +sub toDeclaration { + my $this = shift; + my $name = lc $this->name; + my $size = $this->attribute('size'); + my $result = "char ${name}[${size}];"; + my $prompt = $this->attribute('prompt'); + $result .= "\t/* $prompt */" if defined $prompt; + return $result; +} + + +################################################################################ + +package DBD::Recfield::DBF_CHAR; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + my ($this, $value) = @_; + $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe; + return ($value =~ m/^ $RXint $/x and + $value >= -128 and + $value <= 127); +} + +sub toDeclaration { + return shift->SUPER::toDeclaration("signed char"); +} + + +################################################################################ + +package DBD::Recfield::DBF_UCHAR; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + my ($this, $value) = @_; + $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe; + return ($value =~ m/^ $RXuint $/x and + $value >= 0 and + $value <= 255); +} + +sub toDeclaration { + return shift->SUPER::toDeclaration("unsigned char"); +} + + +################################################################################ + +package DBD::Recfield::DBF_SHORT; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + my ($this, $value) = @_; + $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe; + return ($value =~ m/^ $RXint $/x and + $value >= -32768 and + $value <= 32767); +} + +sub toDeclaration { + return shift->SUPER::toDeclaration("signed short"); +} + + +################################################################################ + +package DBD::Recfield::DBF_USHORT; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + my ($this, $value) = @_; + $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe; + return ($value =~ m/^ $RXuint $/x and + $value >= 0 and + $value <= 65535); +} + +sub toDeclaration { + return shift->SUPER::toDeclaration("unsigned short"); +} + + +################################################################################ + +package DBD::Recfield::DBF_LONG; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + my ($this, $value) = @_; + $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe; + return ($value =~ m/^ $RXint $/x); +} + +sub toDeclaration { + return shift->SUPER::toDeclaration("epicsInt32"); +} + + +################################################################################ + +package DBD::Recfield::DBF_ULONG; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + my ($this, $value) = @_; + $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe; + return ($value =~ m/^ $RXuint $/x and + $value >= 0); +} + +sub toDeclaration { + return shift->SUPER::toDeclaration("unsigned long"); +} + + +################################################################################ + +package DBD::Recfield::DBF_FLOAT; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + my ($this, $value) = @_; + return ($value =~ m/^ $RXnum $/x); +} + +sub toDeclaration { + return shift->SUPER::toDeclaration("float"); +} + + +################################################################################ + +package DBD::Recfield::DBF_DOUBLE; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + my ($this, $value) = @_; + return ($value =~ m/^ $RXnum $/x); +} + +sub toDeclaration { + return shift->SUPER::toDeclaration("double"); +} + + +################################################################################ + +package DBD::Recfield::DBF_ENUM; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + return 1; +} + +sub toDeclaration { + return shift->SUPER::toDeclaration("epicsEnum16"); +} + + +################################################################################ + +package DBD::Recfield::DBF_MENU; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + # FIXME: If we know the menu name and the menu exists, check further + return 1; +} + +sub toDeclaration { + return shift->SUPER::toDeclaration("epicsEnum16"); +} + + +################################################################################ + +package DBD::Recfield::DBF_DEVICE; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + return 1; +} + +sub toDeclaration { + return shift->SUPER::toDeclaration("epicsEnum16"); +} + + +################################################################################ + +package DBD::Recfield::DBF_INLINK; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + return 1; +} + +sub toDeclaration { + return shift->SUPER::toDeclaration("DBLINK"); +} + + +################################################################################ + +package DBD::Recfield::DBF_OUTLINK; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + return 1; +} + +sub toDeclaration { + return shift->SUPER::toDeclaration("DBLINK"); +} + + +################################################################################ + +package DBD::Recfield::DBF_FWDLINK; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + return 1; +} + +sub toDeclaration { + return shift->SUPER::toDeclaration("DBLINK"); +} + + +################################################################################ + +package DBD::Recfield::DBF_NOACCESS; + +use DBD::Base; +@ISA = qw(DBD::Recfield); + +sub legal_value { + my ($this, $value) = @_; + return ($value eq ''); +} + +sub check_valid { + my $this = shift; + dieContext("Type information missing for DBF_NOACCESS field '$name'") + unless defined($this->attribute("extra")); + $this->SUPER::check_valid; +} + +sub toDeclaration { + my $this = shift; + my $name = lc $this->name; + my $result = $this->attribute('extra') . ";"; + my $prompt = $this->attribute('prompt'); + $result .= "\t/* $prompt */" if defined $prompt; + return $result; } 1; diff --git a/src/dbHost/DBD/Recordtype.pm b/src/dbHost/DBD/Recordtype.pm index 2c673d5a6..9708366bc 100644 --- a/src/dbHost/DBD/Recordtype.pm +++ b/src/dbHost/DBD/Recordtype.pm @@ -5,70 +5,82 @@ use DBD::Base; use Carp; sub init { - my $this = shift; - $this->SUPER::init(@_); - $this->{FIELD_LIST} = []; - $this->{FIELD_INDEX} = {}; - $this->{DEVICE_LIST} = []; - $this->{DEVICE_INDEX} = {}; - return $this; + my $this = shift; + $this->SUPER::init(@_); + $this->{FIELD_LIST} = []; + $this->{FIELD_INDEX} = {}; + $this->{DEVICE_LIST} = []; + $this->{DEVICE_INDEX} = {}; + return $this; } sub add_field { - my ($this, $field) = @_; - confess "Not a DBD::Recfield" unless $field->isa('DBD::Recfield'); - my $field_name = $field->name; - dieContext("Duplicate field name '$field_name'") - if exists $this->{FIELD_INDEX}->{$field_name}; - $field->check_valid; - push @{$this->{FIELD_LIST}}, $field; - $this->{FIELD_INDEX}->{$field_name} = $field; + my ($this, $field) = @_; + confess "Not a DBD::Recfield" unless $field->isa('DBD::Recfield'); + my $field_name = $field->name; + dieContext("Duplicate field name '$field_name'") + if exists $this->{FIELD_INDEX}->{$field_name}; + $field->check_valid; + push @{$this->{FIELD_LIST}}, $field; + $this->{FIELD_INDEX}->{$field_name} = $field; } sub fields { - return @{shift->{FIELD_LIST}}; + return @{shift->{FIELD_LIST}}; } sub field_names { # In their original order... - my $this = shift; - my @names = (); - foreach ($this->fields) { - push @names, $_->name - } - return @names; + my $this = shift; + my @names = (); + foreach ($this->fields) { + push @names, $_->name + } + return @names; } sub field { - my ($this, $field_name) = @_; - return $this->{FIELD_INDEX}->{$field_name}; + my ($this, $field_name) = @_; + return $this->{FIELD_INDEX}->{$field_name}; } sub add_device { - my ($this, $device) = @_; - confess "Not a DBD::Device" unless $device->isa('DBD::Device'); - my $choice = $device->choice; - if (exists $this->{DEVICE_INDEX}->{$choice}) { - my @warning = ("Duplicate device type '$choice'"); - my $old = $this->{DEVICE_INDEX}->{$choice}; - push @warning, "Link types differ" - if ($old->link_type ne $device->link_type); - push @warning, "DSETs differ" - if ($old->name ne $device->name); - warnContext(@warning); - return; - } - push @{$this->{DEVICE_LIST}}, $device; - $this->{DEVICE_INDEX}->{$choice} = $device; + my ($this, $device) = @_; + confess "Not a DBD::Device" unless $device->isa('DBD::Device'); + my $choice = $device->choice; + if (exists $this->{DEVICE_INDEX}->{$choice}) { + my @warning = ("Duplicate device type '$choice'"); + my $old = $this->{DEVICE_INDEX}->{$choice}; + push @warning, "Link types differ" + if ($old->link_type ne $device->link_type); + push @warning, "DSETs differ" + if ($old->name ne $device->name); + warnContext(@warning); + return; + } + push @{$this->{DEVICE_LIST}}, $device; + $this->{DEVICE_INDEX}->{$choice} = $device; } sub devices { - my $this = shift; - return @{$this->{DEVICE_LIST}}; + my $this = shift; + return @{$this->{DEVICE_LIST}}; } sub device { - my ($this, $choice) = @_; - return $this->{DEVICE_INDEX}->{$choice}; + my ($this, $choice) = @_; + return $this->{DEVICE_INDEX}->{$choice}; +} + +sub toStruct { + my $this = shift; + my @fields = map { + $_->toDeclaration + } $this->fields; + my $name = $this->name; + $name .= "Record" unless $name eq "dbCommon"; + return "typedef struct $name {\n\t" . + join("\n\t", @fields) . + "\n} $name;\n"; } 1; diff --git a/src/dbHost/dbToMenuH b/src/dbHost/dbToMenuH index 7ccce2c35..5c59c3f37 100755 --- a/src/dbHost/dbToMenuH +++ b/src/dbHost/dbToMenuH @@ -7,7 +7,7 @@ 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]"; + die "Usage: dbToMenuH [-D] [-I dir] [-S macro=val] [-o menu.h] file.dbd [menu.h]"; my @path = map { split /[:;]/ } @opt_I; my $macros = macLib->new(@opt_S); @@ -46,6 +46,6 @@ if ($opt_D) { while (($name, $menu) = each %{$menus}) { print OUTFILE $menu->toEnum; } - print OUTFILE "#endif /* INC_${guard_name} */\n"; + print OUTFILE "\n#endif /* INC_${guard_name} */\n"; close OUTFILE; } diff --git a/src/dbHost/dbToRecordtypeH b/src/dbHost/dbToRecordtypeH new file mode 100755 index 000000000..6c08024c9 --- /dev/null +++ b/src/dbHost/dbToRecordtypeH @@ -0,0 +1,64 @@ +#!/usr/bin/perl + +use DBD; +use DBD::Parser; +use Getopts; +use macLib; +use Readfile; + +getopts('DI@S@o:') or + die "Usage: dbToRecordtypeH [-D] [-I dir] [-S macro=val] [-o menu.h] file.dbd [menu.h]"; + +my @path = map { split /[:;]/ } @opt_I; +my $macros = macLib->new(@opt_S); +my $dbd = DBD->new(); + +my $infile = shift @ARGV; +$infile =~ m/\.dbd$/ or + die "Input file '$infile' must have '.dbd' extension\n"; + +my $outfile; +if ($opt_o) { + $outfile = $opt_o; +} elsif (@ARGV) { + $outfile = shift @ARGV; +} else { + ($outfile = $infile) =~ s/\.dbd$/.h/; +} + +# Derive a name for the include guard +my $guard_name = $outfile; +$guard_name =~ tr/a-zA-Z0-9_/_/cs; +$guard_name =~ s/(_[hH])?$/_H/; + +&ParseDBD($dbd, &Readfile($infile, $macros, \@opt_I)); + +my $rtypes = $dbd->recordtypes; +die "Input file must contain a single recordtype definition.\n" + unless (1 == keys %{$rtypes}); + +if ($opt_D) { + my %filecount; + my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles; + print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n"; + print map { "$_:\n" } @uniqfiles; +} else { + open OUTFILE, ">$outfile" or die "Can't open $outfile: $!\n"; + print OUTFILE "/* $outfile generated from $infile */\n\n", + "#ifndef INC_${guard_name}\n", + "#define INC_${guard_name}\n\n", + "#include \"ellLib.h\"\n", + "#include \"epicsMutex.h\"\n", + "#include \"link.h\"\n", + "#include \"epicsTime.h\"\n", + "#include \"epicsTypes.h\"\n\n"; + my $menus = $dbd->menus; + while (($name, $menu) = each %{$menus}) { + print OUTFILE $menu->toEnum; + } + print OUTFILE "\n"; + my ($name, $rtyp) = each %{$rtypes}; + print OUTFILE $rtyp->toStruct; + print OUTFILE "\n#endif /* INC_${guard_name} */\n"; + close OUTFILE; +} diff --git a/src/dbHost/macLib.pm b/src/dbHost/macLib.pm index 5bd7dd379..22020acc7 100644 --- a/src/dbHost/macLib.pm +++ b/src/dbHost/macLib.pm @@ -65,7 +65,7 @@ sub installList ($@) { sub installMacros ($$) { my $this = shift; $_ = shift; - until (pos($_) == length($_)) { + until (defined pos($_) and pos($_) == length($_)) { m/\G \s* /xgc; # Skip whitespace if (m/\G ( \w+ ) \s* /xgc) { my ($name, $val) = ($1); @@ -166,10 +166,11 @@ sub _translate ($$$$) { sub _trans ($$$$$) { my ($this, $entry, $level, $term, $R) = @_; return $$R - if ($$R =~ m/\A [^\$]* \Z/x); # Short-circuit if no macros + if (!defined $$R or + $$R =~ m/\A [^\$]* \Z/x); # Short-circuit if no macros my $quote = 0; my $val; - until (pos($$R) == length($$R)) { + until (defined pos($$R) and pos($$R) == length($$R)) { if ($term and ($$R =~ m/\G (?= [$term] ) /xgc)) { last; } diff --git a/src/dbHost/test/DBD.pl b/src/dbHost/test/DBD.pl index fb76f95d9..d79341946 100644 --- a/src/dbHost/test/DBD.pl +++ b/src/dbHost/test/DBD.pl @@ -8,50 +8,50 @@ my $dbd = DBD->new; isa_ok $dbd, 'DBD'; is keys %{$dbd->breaktables}, 0, 'No breaktables yet'; -my $reg = DBD::Breaktable->new('Brighton'); -$dbd->add($reg); -my %regs = $dbd->breaktables; -is_deeply \%regs, {Brighton => $reg}, 'Added breaktable'; +my $brk = DBD::Breaktable->new('Brighton'); +$dbd->add($brk); +my %brks = %{$dbd->breaktables}; +is_deeply \%brks, {Brighton => $brk}, 'Added breaktable'; is keys %{$dbd->drivers}, 0, 'No drivers yet'; -my $reg = DBD::Driver->new('Danforth'); -$dbd->add($reg); -my %regs = $dbd->drivers; -is_deeply \%regs, {Danforth => $reg}, 'Added driver'; +my $drv = DBD::Driver->new('Danforth'); +$dbd->add($drv); +my %drvs = %{$dbd->drivers}; +is_deeply \%drvs, {Danforth => $drv}, 'Added driver'; is keys %{$dbd->functions}, 0, 'No functions yet'; -my $reg = DBD::Function->new('Frank'); -$dbd->add($reg); -my %regs = $dbd->functions; -is_deeply \%regs, {Frank => $reg}, 'Added function'; +my $fnc = DBD::Function->new('Frank'); +$dbd->add($fnc); +my %fncs = %{$dbd->functions}; +is_deeply \%fncs, {Frank => $fnc}, 'Added function'; is keys %{$dbd->menus}, 0, 'No menus yet'; my $menu = DBD::Menu->new('Mango'); $dbd->add($menu); -my %menus = $dbd->menus; +my %menus = %{$dbd->menus}; is_deeply \%menus, {Mango => $menu}, 'Added menu'; is $dbd->menu('Mango'), $menu, 'Named menu'; is keys %{$dbd->recordtypes}, 0, 'No recordtypes yet'; my $rtyp = DBD::Recordtype->new('Rita'); $dbd->add($rtyp); -my %rtypes = $dbd->recordtypes; +my %rtypes = %{$dbd->recordtypes}; is_deeply \%rtypes, {Rita => $rtyp}, 'Added recordtype'; is $dbd->recordtype('Rita'), $rtyp, 'Named recordtype'; is keys %{$dbd->registrars}, 0, 'No registrars yet'; my $reg = DBD::Registrar->new('Reggie'); $dbd->add($reg); -my %regs = $dbd->registrars; +my %regs = %{$dbd->registrars}; is_deeply \%regs, {Reggie => $reg}, 'Added registrar'; is keys %{$dbd->variables}, 0, 'No variables yet'; my $ivar = DBD::Variable->new('IntVar'); my $dvar = DBD::Variable->new('DblVar', 'double'); $dbd->add($ivar); -my %vars = $dbd->variables; +my %vars = %{$dbd->variables}; is_deeply \%vars, {IntVar => $ivar}, 'First variable'; $dbd->add($dvar); -%vars = $dbd->variables; +%vars = %{$dbd->variables}; is_deeply \%vars, {IntVar => $ivar, DblVar => $dvar}, 'Second variable'; diff --git a/src/dbHost/test/Recfield.pl b/src/dbHost/test/Recfield.pl index 8807f777a..c67448856 100644 --- a/src/dbHost/test/Recfield.pl +++ b/src/dbHost/test/Recfield.pl @@ -1,16 +1,109 @@ #!/usr/bin/perl -use Test::More tests => 7; +use Test::More tests => 75; use DBD::Recfield; -my $fld = DBD::Recfield->new('test', 'DBF_LONG'); -isa_ok $fld, 'DBD::Recfield'; -is $fld->name, 'test', 'Field name'; -is $fld->dbf_type, 'DBF_LONG', 'Field type'; -is keys %{$fld->attributes}, 0, 'No attributes'; -ok $fld->legal_value("-1234"), 'Legal long value'; -$fld->add_attribute("asl", "ASL0"); -is keys %{$fld->attributes}, 1, "Attribute added"; -$fld->check_valid; -is $fld->attribute("asl"), "ASL0", "Attribute value"; +my $fld_string = DBD::Recfield->new('str', 'DBF_STRING'); +isa_ok $fld_string, 'DBD::Recfield'; +isa_ok $fld_string, 'DBD::Recfield::DBF_STRING'; +$fld_string->add_attribute("size", "41"); +is keys %{$fld_string->attributes}, 1, "Size set"; +ok $fld_string->legal_value("Hello, world!"), 'Legal value'; +ok !$fld_string->legal_value("x"x41), 'Illegal string'; +$fld_string->check_valid; +is $fld_string->toDeclaration, "char str[41];", "C declaration"; + +my $fld_char = DBD::Recfield->new('chr', 'DBF_CHAR'); +isa_ok $fld_char, 'DBD::Recfield'; +isa_ok $fld_char, 'DBD::Recfield::DBF_CHAR'; +is $fld_char->name, 'chr', 'Field name'; +is $fld_char->dbf_type, 'DBF_CHAR', 'Field type'; +ok !$fld_char->legal_value("-129"), 'Illegal - value'; +ok $fld_char->legal_value("-128"), 'Legal - value'; +ok $fld_char->legal_value("127"), 'Legal + value'; +ok !$fld_char->legal_value("0x80"), 'Illegal + hex value'; +$fld_char->check_valid; +is $fld_char->toDeclaration, "signed char chr;", "C declaration"; + +my $fld_uchar = DBD::Recfield->new('uchr', 'DBF_UCHAR'); +isa_ok $fld_uchar, 'DBD::Recfield'; +isa_ok $fld_uchar, 'DBD::Recfield::DBF_UCHAR'; +is $fld_uchar->name, 'uchr', 'Field name'; +is $fld_uchar->dbf_type, 'DBF_UCHAR', 'Field type'; +ok !$fld_uchar->legal_value("-1"), 'Illegal - value'; +ok $fld_uchar->legal_value("0"), 'Legal 0 value'; +ok $fld_uchar->legal_value("0377"), 'Legal + value'; +ok !$fld_uchar->legal_value("0400"), 'Illegal + octal value'; +$fld_uchar->check_valid; +is $fld_uchar->toDeclaration, "unsigned char uchr;", "C declaration"; + +my $fld_short = DBD::Recfield->new('shrt', 'DBF_SHORT'); +isa_ok $fld_short, 'DBD::Recfield'; +isa_ok $fld_short, 'DBD::Recfield::DBF_SHORT'; +is $fld_short->name, 'shrt', 'Field name'; +is $fld_short->dbf_type, 'DBF_SHORT', 'Field type'; +ok !$fld_short->legal_value("-32769"), 'Illegal - value'; +ok $fld_short->legal_value("-32768"), 'Legal - value'; +ok $fld_short->legal_value("32767"), 'Legal + value'; +ok !$fld_short->legal_value("0x8000"), 'Illegal + hex value'; +$fld_short->check_valid; +is $fld_short->toDeclaration, "signed short shrt;", "C declaration"; + +my $fld_ushort = DBD::Recfield->new('ushrt', 'DBF_USHORT'); +isa_ok $fld_ushort, 'DBD::Recfield'; +isa_ok $fld_ushort, 'DBD::Recfield::DBF_USHORT'; +is $fld_ushort->name, 'ushrt', 'Field name'; +is $fld_ushort->dbf_type, 'DBF_USHORT', 'Field type'; +ok !$fld_ushort->legal_value("-1"), 'Illegal - value'; +ok $fld_ushort->legal_value("0"), 'Legal 0 value'; +ok $fld_ushort->legal_value("65535"), 'Legal + value'; +ok !$fld_ushort->legal_value("0x10000"), 'Illegal + hex value'; +$fld_ushort->check_valid; +is $fld_ushort->toDeclaration, "unsigned short ushrt;", "C declaration"; + +my $fld_long = DBD::Recfield->new('lng', 'DBF_LONG'); +isa_ok $fld_long, 'DBD::Recfield'; +isa_ok $fld_long, 'DBD::Recfield::DBF_LONG'; +is $fld_long->name, 'lng', 'Field name'; +is $fld_long->dbf_type, 'DBF_LONG', 'Field type'; +ok $fld_long->legal_value("-12345678"), 'Legal - value'; +ok $fld_long->legal_value("0x12345678"), 'Legal + value'; +ok !$fld_long->legal_value("0xfigure"), 'Illegal value'; +$fld_long->check_valid; +is $fld_long->toDeclaration, "epicsInt32 lng;", "C declaration"; + +my $fld_ulong = DBD::Recfield->new('ulng', 'DBF_ULONG'); +isa_ok $fld_ulong, 'DBD::Recfield'; +isa_ok $fld_ulong, 'DBD::Recfield::DBF_ULONG'; +is $fld_ulong->name, 'ulng', 'Field name'; +is $fld_ulong->dbf_type, 'DBF_ULONG', 'Field type'; +ok !$fld_ulong->legal_value("-1"), 'Illegal - value'; +ok $fld_ulong->legal_value("00"), 'Legal 0 value'; +ok $fld_ulong->legal_value("0xffffffff"), 'Legal + value'; +ok !$fld_ulong->legal_value("0xfacepaint"), 'Illegal value'; +$fld_ulong->check_valid; +is $fld_ulong->toDeclaration, "unsigned long ulng;", "C declaration"; + +my $fld_float = DBD::Recfield->new('flt', 'DBF_FLOAT'); +isa_ok $fld_float, 'DBD::Recfield'; +isa_ok $fld_float, 'DBD::Recfield::DBF_FLOAT'; +is $fld_float->name, 'flt', 'Field name'; +is $fld_float->dbf_type, 'DBF_FLOAT', 'Field type'; +ok $fld_float->legal_value("-1.2345678e9"), 'Legal - value'; +ok $fld_float->legal_value("0.12345678e9"), 'Legal + value'; +ok !$fld_float->legal_value("0x1.5"), 'Illegal value'; +$fld_float->check_valid; +is $fld_float->toDeclaration, "float flt;", "C declaration"; + +my $fld_double = DBD::Recfield->new('dbl', 'DBF_DOUBLE'); +isa_ok $fld_double, 'DBD::Recfield'; +isa_ok $fld_double, 'DBD::Recfield::DBF_DOUBLE'; +is $fld_double->name, 'dbl', 'Field name'; +is $fld_double->dbf_type, 'DBF_DOUBLE', 'Field type'; +ok $fld_double->legal_value("-12345e-67"), 'Legal - value'; +ok $fld_double->legal_value("12345678e+9"), 'Legal + value'; +ok !$fld_double->legal_value("e5"), 'Illegal value'; +$fld_double->check_valid; +is $fld_double->toDeclaration, "double dbl;", "C declaration"; + From a1b72626eca1edcfb13cc3ec91aa84fc068428bb Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 15:55:49 -0500 Subject: [PATCH 08/32] 2004-07-12: More implementation, can't remember the details now. --- src/dbHost/DBD.pm | 3 +- src/dbHost/DBD/Base.pm | 17 ++++---- src/dbHost/DBD/Breaktable.pm | 4 +- src/dbHost/DBD/Device.pm | 11 +++--- src/dbHost/DBD/Menu.pm | 8 ++-- src/dbHost/DBD/Parser.pm | 59 ++++++++++++++-------------- src/dbHost/DBD/Recfield.pm | 69 ++++++++++++++++++-------------- src/dbHost/DBD/Recordtype.pm | 3 +- src/dbHost/DBD/Variable.pm | 2 +- src/dbHost/Readfile.pm | 74 +++++++++++++++++------------------ src/dbHost/dbToMenuH | 24 ++++++------ src/dbHost/dbToRecordtypeH | 58 +++++++++++++++++++-------- src/dbHost/test/Base.pl | 8 ---- src/dbHost/test/Recfield.pl | 4 +- src/dbHost/test/Recordtype.pl | 5 ++- 15 files changed, 191 insertions(+), 158 deletions(-) delete mode 100644 src/dbHost/test/Base.pl diff --git a/src/dbHost/DBD.pm b/src/dbHost/DBD.pm index 400d39003..edc403811 100644 --- a/src/dbHost/DBD.pm +++ b/src/dbHost/DBD.pm @@ -13,8 +13,7 @@ use DBD::Variable; use Carp; sub new { - my $proto = shift; - my $class = ref($proto) || $proto; + my ($class) = @_; my $this = { 'DBD::Breaktable' => {}, 'DBD::Driver' => {}, diff --git a/src/dbHost/DBD/Base.pm b/src/dbHost/DBD/Base.pm index f65b99c4b..1c545bd1c 100644 --- a/src/dbHost/DBD/Base.pm +++ b/src/dbHost/DBD/Base.pm @@ -55,15 +55,15 @@ sub warnContext { # Input checking -sub unquote { - my ($string) = @_; - $string =~ m/^"(.*)"$/o and $string = $1; - return $string; +sub unquote (\$) { + my ($s) = @_; + $$s =~ s/^"(.*)"$/$1/o; + return $$s; } sub identifier { - my $id = unquote(shift); - my $what = shift; + my ($id, $what) = @_; + unquote $id; confess "$what undefined!" unless defined $id; $id =~ m/^$RXident$/o or dieContext("Illegal $what '$id'", "Identifiers are used in C code so must start with a letter, followed", @@ -75,7 +75,7 @@ sub identifier { # Output filtering sub escapeCcomment { - $_ = shift; + ($_) = @_; s/\*\//**/; return $_; } @@ -87,8 +87,7 @@ sub escapeCstring { # Base class routines for the DBD component objects sub new { - my $proto = shift; - my $class = ref($proto) || $proto; + my $class = shift; my $this = {}; bless $this, $class; return $this->init(@_); diff --git a/src/dbHost/DBD/Breaktable.pm b/src/dbHost/DBD/Breaktable.pm index 3db134347..5199d61fb 100644 --- a/src/dbHost/DBD/Breaktable.pm +++ b/src/dbHost/DBD/Breaktable.pm @@ -14,9 +14,9 @@ sub init { sub add_point { my ($this, $raw, $eng) = @_; confess "Raw value undefined!" unless defined $raw; - $raw = unquote($raw); confess "Engineering value undefined!" unless defined $eng; - $eng = unquote($eng); + unquote $raw; + unquote $eng; push @{$this->{POINT_LIST}}, [$raw, $eng]; } diff --git a/src/dbHost/DBD/Device.pm b/src/dbHost/DBD/Device.pm index bd60e0075..f439c6d86 100644 --- a/src/dbHost/DBD/Device.pm +++ b/src/dbHost/DBD/Device.pm @@ -18,11 +18,12 @@ my %link_types = ( sub init { my ($this, $link_type, $dset, $choice) = @_; + unquote $choice; dieContext("Unknown link type '$link_type', valid types are:", sort keys %link_types) unless exists $link_types{$link_type}; $this->SUPER::init($dset, "DSET name"); $this->{LINK_TYPE} = $link_type; - $this->{CHOICE} = unquote($choice); + $this->{CHOICE} = $choice; return $this; } @@ -35,10 +36,10 @@ sub choice { } sub legal_addr { - my $this = shift; - my $addr = unquote(shift); - my $rx = $link_types{$this->{LINK_TYPE}}; - return $addr =~ m/^ $rx $/x; + my ($this, $addr) = @_; + my $rx = $link_types{$this->{LINK_TYPE}}; + unquote $addr; + return $addr =~ m/^ $rx $/x; } 1; diff --git a/src/dbHost/DBD/Menu.pm b/src/dbHost/DBD/Menu.pm index 3ab7ccc38..10fff09e5 100644 --- a/src/dbHost/DBD/Menu.pm +++ b/src/dbHost/DBD/Menu.pm @@ -13,7 +13,7 @@ sub init { sub add_choice { my ($this, $name, $value) = @_; $name = identifier($name, "Choice name"); - $value = unquote($value, "Choice value"); + unquote $value; foreach $pair ($this->choices) { dieContext("Duplicate choice name") if ($pair->[0] eq $name); dieContext("Duplicate choice string") if ($pair->[1] eq $value); @@ -32,12 +32,12 @@ sub choice { } sub legal_choice { - my $this = shift; - my $value = unquote(shift); + my ($this, $value) = @_; + unquote $value; return exists $this->{CHOICE_INDEX}->{$value}; } -sub toEnum { +sub toDeclaration { my $this = shift; my @choices = map { "\t" . @{$_}[0] . "\t/* " . escapeCcomment(@{$_}[1]) . " */" diff --git a/src/dbHost/DBD/Parser.pm b/src/dbHost/DBD/Parser.pm index 14f456ef9..7e8c21d29 100644 --- a/src/dbHost/DBD/Parser.pm +++ b/src/dbHost/DBD/Parser.pm @@ -26,10 +26,10 @@ our $debug=0; sub ParseDBD { my $dbd = shift; - $_ = join '', @_; + $_ = shift; while (1) { - if (parseCommon()) {} - elsif (m/\G menu \s* \( \s* $string \s* \) \s* \{/oxgc) { + parseCommon(); + if (m/\G menu \s* \( \s* $string \s* \) \s* \{/oxgc) { print "Menu: $1\n" if $debug; parse_menu($dbd, $1); } @@ -75,24 +75,27 @@ sub ParseDBD { } sub parseCommon { - # Skip leading whitespace - m/\G \s* /oxgc; + while (1) { + # Skip leading whitespace + m/\G \s* /oxgc; - if (m/\G \#\#!BEGIN\{ ( [^}]* ) \}!\#\# \n/oxgc) { - print "File-Begin: $1\n" if $debug; - pushContext("file '$1'"); + if (m/\G \# /oxgc) { + if (m/\G \#!BEGIN\{ ( [^}]* ) \}!\#\# \n/oxgc) { + print "File-Begin: $1\n" if $debug; + pushContext("file '$1'"); + } + elsif (m/\G \#!END\{ ( [^}]* ) \}!\#\# \n?/oxgc) { + print "File-End: $1\n" if $debug; + popContext("file '$1'"); + } + else { + m/\G (.*) \n/oxgc; + print "Comment: $1\n" if $debug; + } + } else { + return; + } } - elsif (m/\G \#\#!END\{ ( [^}]* ) \}!\#\# \n/oxgc) { - print "File-End: $1\n" if $debug; - popContext("file '$1'"); - } - elsif (m/\G \# (.*) \n/oxgc) { - print "Comment: $1\n" if $debug; - } - else { - return 0; - } - return 1; } sub parse_menu { @@ -100,9 +103,8 @@ sub parse_menu { pushContext("menu($name)"); my $menu = DBD::Menu->new($name); while(1) { - if (parseCommon()) {} - elsif (m/\G choice \s* \( \s* $string \s* , - \s* $string \s* \)/oxgc) { + parseCommon(); + if (m/\G choice \s* \( \s* $string \s* , \s* $string \s* \)/oxgc) { print " Menu-Choice: $1, $2\n" if $debug; $menu->add_choice($1, $2); } @@ -123,8 +125,8 @@ sub parse_breaktable { pushContext("breaktable($name)"); my $bt = DBD::Breaktable->new($name); while(1) { - if (parseCommon()) {} - elsif (m/\G point\s* \(\s* $string \s* , \s* $string \s* \)/oxgc) { + parseCommon(); + if (m/\G point\s* \(\s* $string \s* , \s* $string \s* \)/oxgc) { print " Breaktable-Point: $1, $2\n" if $debug; $bt->add_point($1, $2); } @@ -149,9 +151,8 @@ sub parse_recordtype { pushContext("recordtype($name)"); my $rtyp = DBD::Recordtype->new($name); while(1) { - if (parseCommon()) {} - elsif (m/\G field \s* \( \s* $string \s* , - \s* $string \s* \) \s* \{/oxgc) { + parseCommon(); + if (m/\G field \s* \( \s* $string \s* , \s* $string \s* \) \s* \{/oxgc) { print " Recordtype-Field: $1, $2\n" if $debug; parse_field($rtyp, $1, $2); } @@ -172,8 +173,8 @@ sub parse_field { my $fld = DBD::Recfield->new($name, $field_type); pushContext("field($name, $field_type)"); while(1) { - if (parseCommon()) {} - elsif (m/\G (\w+) \s* \( \s* $string \s* \)/oxgc) { + parseCommon(); + if (m/\G (\w+) \s* \( \s* $string \s* \)/oxgc) { print " Field-Attribute: $1, $2\n" if $debug; $fld->add_attribute($1, $2); } diff --git a/src/dbHost/DBD/Recfield.pm b/src/dbHost/DBD/Recfield.pm index b1711c76e..63d7d0d59 100644 --- a/src/dbHost/DBD/Recfield.pm +++ b/src/dbHost/DBD/Recfield.pm @@ -24,17 +24,17 @@ our %field_types = ( # The hash value is a regexp that matches all legal values of this attribute our %field_attrs = ( - asl => qr/ASL[01]/, - initial => qr/.*/, - promptgroup => qr/GUI_\w+/, - prompt => qr/.*/, - special => qr/(?:SPC_\w+|\d{3,})/, - pp => qr/(?:YES|NO|TRUE|FALSE)/, - interest => qr/\d+/, - base => qr/(?:DECIMAL|HEX)/, - size => qr/\d+/, - extra => qr/.*/, - menu => qr/$RXident/o + asl => qr/^ASL[01]$/, + initial => qr/^.*$/, + promptgroup => qr/^GUI_\w+$/, + prompt => qr/^.*$/, + special => qr/^(?:SPC_\w+|\d{3,})$/, + pp => qr/^(?:YES|NO|TRUE|FALSE)$/, + interest => qr/^\d+$/, + base => qr/^(?:DECIMAL|HEX)$/, + size => qr/^\d+$/, + extra => qr/^.*$/, + menu => qr/^$RXident$/o ); sub new { @@ -47,9 +47,8 @@ sub new { } sub init { - my $this = shift; - my $name = shift; - my $type = unquote(shift); + my ($this, $name, $type) = @_; + unquote $type; $this->SUPER::init($name, "record field name"); dieContext("Illegal field type '$type', valid field types are:", sort keys %field_types) unless exists $field_types{$type}; @@ -62,15 +61,24 @@ sub dbf_type { return shift->{DBF_TYPE}; } +sub set_number { + my ($this, $number) = @_; + $this->{NUMBER} = $number; +} + +sub number { + return shift->{NUMBER}; +} + sub add_attribute { - my $this = shift; - my $attr = shift; - my $value = unquote(shift); + my ($this, $attr, $value) = @_; + unquote $value; + my $match = $field_attrs{$attr}; dieContext("Unknown field attribute '$1', valid attributes are:", sort keys %field_attrs) - unless exists $field_attrs{$attr}; + unless defined $match; dieContext("Bad value '$value' for field '$attr' attribute") - unless $value =~ m/^ $field_attrs{$attr} $/x; + unless $value =~ m/$match/; $this->{ATTR_INDEX}->{$attr} = $value; } @@ -84,17 +92,13 @@ sub attribute { } sub check_valid { - my $this = shift; + my ($this) = @_; my $name = $this->name; my $default = $this->attribute("initial"); dieContext("Default value '$default' is invalid for field '$name'") if (defined($default) and !$this->legal_value($default)); } -# dieContext("Menu name missing for field '$name'") -# if ($this->dbf_type eq "DBF_MENU" and -# !defined($this->attribute("menu"))); - sub toDeclaration { my ($this, $ctype) = @_; my $name = lc $this->name; @@ -119,14 +123,14 @@ sub legal_value { } sub check_valid { - my $this = shift; + my ($this) = @_; dieContext("Size missing for DBF_STRING field '$name'") unless exists $this->attributes->{'size'}; $this->SUPER::check_valid; } sub toDeclaration { - my $this = shift; + my ($this) = @_; my $name = lc $this->name; my $size = $this->attribute('size'); my $result = "char ${name}[${size}];"; @@ -192,7 +196,7 @@ sub legal_value { } sub toDeclaration { - return shift->SUPER::toDeclaration("signed short"); + return shift->SUPER::toDeclaration("short"); } @@ -315,6 +319,13 @@ sub legal_value { return 1; } +sub check_valid { + my ($this) = @_; + dieContext("Menu name missing for DBF_MENU field '$name'") + unless defined($this->attribute("menu")); + $this->SUPER::check_valid; +} + sub toDeclaration { return shift->SUPER::toDeclaration("epicsEnum16"); } @@ -397,14 +408,14 @@ sub legal_value { } sub check_valid { - my $this = shift; + my ($this) = @_; dieContext("Type information missing for DBF_NOACCESS field '$name'") unless defined($this->attribute("extra")); $this->SUPER::check_valid; } sub toDeclaration { - my $this = shift; + my ($this) = @_; my $name = lc $this->name; my $result = $this->attribute('extra') . ";"; my $prompt = $this->attribute('prompt'); diff --git a/src/dbHost/DBD/Recordtype.pm b/src/dbHost/DBD/Recordtype.pm index 9708366bc..3160a70f2 100644 --- a/src/dbHost/DBD/Recordtype.pm +++ b/src/dbHost/DBD/Recordtype.pm @@ -21,6 +21,7 @@ sub add_field { dieContext("Duplicate field name '$field_name'") if exists $this->{FIELD_INDEX}->{$field_name}; $field->check_valid; + $field->set_number(scalar @{$this->{FIELD_LIST}}); push @{$this->{FIELD_LIST}}, $field; $this->{FIELD_INDEX}->{$field_name} = $field; } @@ -71,7 +72,7 @@ sub device { return $this->{DEVICE_INDEX}->{$choice}; } -sub toStruct { +sub toDeclaration { my $this = shift; my @fields = map { $_->toDeclaration diff --git a/src/dbHost/DBD/Variable.pm b/src/dbHost/DBD/Variable.pm index c0b78a2ff..11f5a2c05 100644 --- a/src/dbHost/DBD/Variable.pm +++ b/src/dbHost/DBD/Variable.pm @@ -7,7 +7,7 @@ my %var_types = ("int" => 1, "double" => 1); sub init { my ($this, $name, $type) = @_; if (defined $type) { - $type = unquote($type); + unquote $type; } else { $type = "int"; } diff --git a/src/dbHost/Readfile.pm b/src/dbHost/Readfile.pm index dda27e49d..371f3c666 100644 --- a/src/dbHost/Readfile.pm +++ b/src/dbHost/Readfile.pm @@ -15,14 +15,14 @@ sub slurp { my @path = @{$Rpath}; print "slurp($FILE):\n" if $debug; if ($FILE !~ m[/]) { - foreach $dir (@path) { - print " trying $dir/$FILE\n" if $debug; - if (-r "$dir/$FILE") { - $FILE = "$dir/$FILE"; - last; - } - } - die "Can't find file '$FILE'\n" unless -r $FILE; + foreach $dir (@path) { + print " trying $dir/$FILE\n" if $debug; + if (-r "$dir/$FILE") { + $FILE = "$dir/$FILE"; + last; + } + } + die "Can't find file '$FILE'\n" unless -r $FILE; } print " opening $FILE\n" if $debug; open FILE, "<$FILE" or die "Can't open $FILE: $!\n"; @@ -32,16 +32,13 @@ sub slurp { push @lines, "##!END{$FILE}!##\n"; close FILE or die "Error closing $FILE: $!\n"; print " read ", scalar @lines, " lines\n" if $debug; - return @lines; + return join '', @lines; } sub expandMacros { - my ($macros, @input) = @_; - my @output; - foreach (@input) { - push @output, $macros->expandString($_); - } - return @output; + my ($macros, $input) = @_; + return $input unless $macros; + return $macros->expandString($input); } sub splitPath { @@ -56,37 +53,38 @@ my $RXnam = qr/[a-zA-Z0-9_\-:.[\]<>;]+/o; my $string = qr/ ( $RXnam | $RXstr ) /ox; sub unquote { - my ($string) = @_; - $string = $1 if $string =~ m/^"(.*)"$/o; - return $string; + my ($s) = @_; + $s =~ s/^"(.*)"$/$1/o; + return $s; } sub Readfile { my ($file, $macros, $Rpath) = @_; print "Readfile($file)\n" if $debug; - my @input = &expandMacros($macros, &slurp($file, $Rpath)); + my $input = &expandMacros($macros, &slurp($file, $Rpath)); + my @input = split /\n/, $input; my @output; foreach (@input) { - if (m/^ \s* include \s+ $string /ox) { - $arg = &unquote($1); - print " include $arg\n" if $debug; - push @output, "##! include \"$arg\"\n"; - push @output, &Readfile($arg, $macros, $Rpath); - } elsif (m/^ \s* addpath \s+ $string /ox) { - $arg = &unquote($1); - print " addpath $arg\n" if $debug; - push @output, "##! addpath \"$arg\"\n"; - push @{$Rpath}, &splitPath($arg); - } elsif (m/^ \s* path \s+ $string /ox) { - $arg = &unquote($1); - print " path $arg\n" if $debug; - push @output, "##! path \"$arg\"\n"; - @{$Rpath} = &splitPath($arg); - } else { - push @output, $_; - } + if (m/^ \s* include \s+ $string /ox) { + $arg = &unquote($1); + print " include $arg\n" if $debug; + push @output, "##! include \"$arg\""; + push @output, &Readfile($arg, $macros, $Rpath); + } elsif (m/^ \s* addpath \s+ $string /ox) { + $arg = &unquote($1); + print " addpath $arg\n" if $debug; + push @output, "##! addpath \"$arg\""; + push @{$Rpath}, &splitPath($arg); + } elsif (m/^ \s* path \s+ $string /ox) { + $arg = &unquote($1); + print " path $arg\n" if $debug; + push @output, "##! path \"$arg\""; + @{$Rpath} = &splitPath($arg); + } else { + push @output, $_; + } } - return @output; + return join "\n", @output; } 1; diff --git a/src/dbHost/dbToMenuH b/src/dbHost/dbToMenuH index 5c59c3f37..953160743 100755 --- a/src/dbHost/dbToMenuH +++ b/src/dbHost/dbToMenuH @@ -6,16 +6,16 @@ use Getopts; use macLib; use Readfile; -getopts('DI@S@o:') or - die "Usage: dbToMenuH [-D] [-I dir] [-S macro=val] [-o menu.h] file.dbd [menu.h]"; +my $tool = 'dbToMenuH'; +getopts('DI@o:') or + die "Usage: $tool: [-D] [-I dir] [-o menu.h] menu.dbd [menu.h]\n"; my @path = map { split /[:;]/ } @opt_I; -my $macros = macLib->new(@opt_S); my $dbd = DBD->new(); my $infile = shift @ARGV; $infile =~ m/\.dbd$/ or - die "Input file '$infile' must have '.dbd' extension\n"; + die "$tool: Input file '$infile' must have '.dbd' extension\n"; my $outfile; if ($opt_o) { @@ -24,13 +24,15 @@ if ($opt_o) { $outfile = shift @ARGV; } else { ($outfile = $infile) =~ s/\.dbd$/.h/; + $outfile =~ s/^.*\///; } # Derive a name for the include guard -($guard_name = $outfile) =~ tr/a-zA-Z0-9_/_/cs; +my $guard_name = "INC_$outfile"; +$guard_name =~ tr/a-zA-Z0-9_/_/cs; $guard_name =~ s/(_[hH])?$/_H/; -&ParseDBD($dbd, &Readfile($infile, $macros, \@opt_I)); +&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I)); if ($opt_D) { my %filecount; @@ -38,14 +40,14 @@ if ($opt_D) { print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n"; print map { "$_:\n" } @uniqfiles; } else { - open OUTFILE, ">$outfile" or die "Can't open $outfile: $!\n"; + open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n"; print OUTFILE "/* $outfile generated from $infile */\n\n", - "#ifndef INC_${guard_name}\n", - "#define INC_${guard_name}\n\n"; + "#ifndef $guard_name\n", + "#define $guard_name\n\n"; my $menus = $dbd->menus; while (($name, $menu) = each %{$menus}) { - print OUTFILE $menu->toEnum; + print OUTFILE $menu->toDeclaration; } - print OUTFILE "\n#endif /* INC_${guard_name} */\n"; + print OUTFILE "\n#endif /* $guard_name */\n"; close OUTFILE; } diff --git a/src/dbHost/dbToRecordtypeH b/src/dbHost/dbToRecordtypeH index 6c08024c9..a009fec43 100755 --- a/src/dbHost/dbToRecordtypeH +++ b/src/dbHost/dbToRecordtypeH @@ -6,16 +6,16 @@ use Getopts; use macLib; use Readfile; -getopts('DI@S@o:') or - die "Usage: dbToRecordtypeH [-D] [-I dir] [-S macro=val] [-o menu.h] file.dbd [menu.h]"; +my $tool = 'dbToRecordtypeH'; +getopts('DI@o:') or + die "Usage: $tool [-D] [-I dir] [-o xRecord.h] xRecord.dbd [xRecord.h]\n"; my @path = map { split /[:;]/ } @opt_I; -my $macros = macLib->new(@opt_S); my $dbd = DBD->new(); my $infile = shift @ARGV; $infile =~ m/\.dbd$/ or - die "Input file '$infile' must have '.dbd' extension\n"; + die "$tool: Input file '$infile' must have '.dbd' extension\n"; my $outfile; if ($opt_o) { @@ -24,41 +24,65 @@ if ($opt_o) { $outfile = shift @ARGV; } else { ($outfile = $infile) =~ s/\.dbd$/.h/; + $outfile =~ s/^.*\///; + $outfile =~ s/dbCommonRecord/dbCommon/; } # Derive a name for the include guard -my $guard_name = $outfile; +my $guard_name = "INC_$outfile"; $guard_name =~ tr/a-zA-Z0-9_/_/cs; $guard_name =~ s/(_[hH])?$/_H/; -&ParseDBD($dbd, &Readfile($infile, $macros, \@opt_I)); +&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I)); my $rtypes = $dbd->recordtypes; -die "Input file must contain a single recordtype definition.\n" +die "$tool: Input file must contain a single recordtype definition.\n" unless (1 == keys %{$rtypes}); -if ($opt_D) { +if ($opt_D) { # Output dependencies only, to stdout my %filecount; my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles; print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n"; print map { "$_:\n" } @uniqfiles; } else { - open OUTFILE, ">$outfile" or die "Can't open $outfile: $!\n"; + open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n"; print OUTFILE "/* $outfile generated from $infile */\n\n", - "#ifndef INC_${guard_name}\n", - "#define INC_${guard_name}\n\n", + "#ifndef $guard_name\n", + "#define $guard_name\n\n", "#include \"ellLib.h\"\n", "#include \"epicsMutex.h\"\n", "#include \"link.h\"\n", "#include \"epicsTime.h\"\n", - "#include \"epicsTypes.h\"\n\n"; + "#include \"epicsTypes.h\"\n", + "#include \"epicsExport.h\"\n\n", + "#ifdef __cplusplus\n", + "extern \"C\" {\n", + "#endif\n\n"; + my $menus = $dbd->menus; while (($name, $menu) = each %{$menus}) { - print OUTFILE $menu->toEnum; + print OUTFILE $menu->toDeclaration; } - print OUTFILE "\n"; - my ($name, $rtyp) = each %{$rtypes}; - print OUTFILE $rtyp->toStruct; - print OUTFILE "\n#endif /* INC_${guard_name} */\n"; + print OUTFILE "\n" if scalar %{$menus}; + + my ($rn, $rtyp) = each %{$rtypes}; + print OUTFILE $rtyp->toDeclaration; + + unless ($rn eq 'dbCommon') { + print OUTFILE "\nenum {\n", + join(",\n", map { "\t${rn}Record$_" } $rtyp->field_names), + "\n};\n\n"; + + print OUTFILE "#ifdef GEN_SIZE_OFFSET\n", + "static int ${rn}RecordSizeOffset(dbRecordType *pdbRecordType)\n", + "{\n"; + # ... FIXME: add size-offset data, etc. + print OUTFILE "}\n\n", + "epicsExportRegistrar(${rn}RecordSizeOffset);\n\n"; + } + print OUTFILE "#ifdef __cplusplus\n", + "} /* extern \"C\" */\n", + "#endif\n\n", + "#endif /* $guard_name */\n"; close OUTFILE; } diff --git a/src/dbHost/test/Base.pl b/src/dbHost/test/Base.pl deleted file mode 100644 index fd600be51..000000000 --- a/src/dbHost/test/Base.pl +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/perl - -use Test::More tests => 2; - -use DBD::Base; - -is unquote('"x"'), 'x', '"unquote"'; -isnt unquote('x""'), 'x', 'unquote""'; diff --git a/src/dbHost/test/Recfield.pl b/src/dbHost/test/Recfield.pl index c67448856..d88d11a68 100644 --- a/src/dbHost/test/Recfield.pl +++ b/src/dbHost/test/Recfield.pl @@ -1,12 +1,14 @@ #!/usr/bin/perl -use Test::More tests => 75; +use Test::More tests => 76; use DBD::Recfield; my $fld_string = DBD::Recfield->new('str', 'DBF_STRING'); isa_ok $fld_string, 'DBD::Recfield'; isa_ok $fld_string, 'DBD::Recfield::DBF_STRING'; +$fld_string->set_number(0); +is $fld_string->number, 0, 'Field number'; $fld_string->add_attribute("size", "41"); is keys %{$fld_string->attributes}, 1, "Size set"; ok $fld_string->legal_value("Hello, world!"), 'Legal value'; diff --git a/src/dbHost/test/Recordtype.pl b/src/dbHost/test/Recordtype.pl index d4d47d6c6..a0545b8c0 100644 --- a/src/dbHost/test/Recordtype.pl +++ b/src/dbHost/test/Recordtype.pl @@ -1,6 +1,6 @@ #!/usr/bin/perl -use Test::More tests => 12; +use Test::More tests => 14; use DBD::Recordtype; use DBD::Recfield; @@ -32,6 +32,9 @@ is_deeply \@names, ['NAME', 'DTYP'], 'Field name list'; is $rtyp->field('NAME'), $fld1, 'Field name lookup'; +is $fld1->number, 0, 'Field number 0'; +is $fld2->number, 1, 'Field number 1'; + is $rtyp->devices, 0, 'No devices yet'; my $dev1 = DBD::Device->new('INST_IO', 'testDset', 'test device'); From daa0630361edfe2c0ca4acb48a11a3bb9e2e882c Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 16:18:03 -0500 Subject: [PATCH 09/32] 2004-07-30: Work continues. Make dbToRecordtypeH generate the same output as my 2002 C++ code. Other changes in testing and macros. --- src/dbHost/DBD/Base.pm | 5 +- src/dbHost/DBD/Menu.pm | 20 ++++++- src/dbHost/DBD/Recfield.pm | 16 +++--- src/dbHost/DBD/Recordtype.pm | 4 +- src/dbHost/dbToMenuH | 7 ++- src/dbHost/dbToRecordtypeH | 103 +++++++++++++++++++++++++++++------ src/dbHost/macLib.pm | 36 ++++++------ 7 files changed, 144 insertions(+), 47 deletions(-) diff --git a/src/dbHost/DBD/Base.pm b/src/dbHost/DBD/Base.pm index 1c545bd1c..e58d9bc26 100644 --- a/src/dbHost/DBD/Base.pm +++ b/src/dbHost/DBD/Base.pm @@ -76,11 +76,14 @@ sub identifier { sub escapeCcomment { ($_) = @_; - s/\*\//**/; + s/\*\//**/g; return $_; } sub escapeCstring { + ($_) = @_; + # How to do this? + return $_; } diff --git a/src/dbHost/DBD/Menu.pm b/src/dbHost/DBD/Menu.pm index 10fff09e5..a96690cdb 100644 --- a/src/dbHost/DBD/Menu.pm +++ b/src/dbHost/DBD/Menu.pm @@ -39,12 +39,28 @@ sub legal_choice { sub toDeclaration { my $this = shift; + my $name = $this->name; my @choices = map { "\t" . @{$_}[0] . "\t/* " . escapeCcomment(@{$_}[1]) . " */" } $this->choices; return "typedef enum {\n" . - join(",\n", @choices) . - "\n} " . $this->name . ";\n"; + join(",\n", @choices) . + "\n\t${name}_NUM_CHOICES\n" . + "} $name;\n"; +} + +sub toDefinition { + my $this = shift; + my $name = $this->name; + my @strings = map { + "\t\"" . escapeCstring(@{$_}[1]) . "\"" + } $this->choices; + return "static const char * const ${name}MenuData = {\n" . + join(",\n", @strings) . "};\n\n" . + "dbMenu ${name}MenuData = {\n" . + "\t\"" . escapeCstring(name) . "\",\n" . + "\t${name}_NUM_CHOICES,\n" . + "\t${name}ChoiceStrings\n};\n"; } 1; diff --git a/src/dbHost/DBD/Recfield.pm b/src/dbHost/DBD/Recfield.pm index 63d7d0d59..9b3b76ee6 100644 --- a/src/dbHost/DBD/Recfield.pm +++ b/src/dbHost/DBD/Recfield.pm @@ -29,7 +29,7 @@ our %field_attrs = ( promptgroup => qr/^GUI_\w+$/, prompt => qr/^.*$/, special => qr/^(?:SPC_\w+|\d{3,})$/, - pp => qr/^(?:YES|NO|TRUE|FALSE)$/, + pp => qr/^(?:TRUE|FALSE)$/, interest => qr/^\d+$/, base => qr/^(?:DECIMAL|HEX)$/, size => qr/^\d+$/, @@ -102,9 +102,9 @@ sub check_valid { sub toDeclaration { my ($this, $ctype) = @_; my $name = lc $this->name; - my $result = "$ctype $name;"; + my $result = sprintf " %-19s %-12s", $ctype, "$name;"; my $prompt = $this->attribute('prompt'); - $result .= "\t/* $prompt */" if defined $prompt; + $result .= "/* $prompt */" if defined $prompt; return $result; } @@ -133,9 +133,9 @@ sub toDeclaration { my ($this) = @_; my $name = lc $this->name; my $size = $this->attribute('size'); - my $result = "char ${name}[${size}];"; + my $result = sprintf " %-19s %-12s", 'char', "${name}[${size}];"; my $prompt = $this->attribute('prompt'); - $result .= "\t/* $prompt */" if defined $prompt; + $result .= "/* $prompt */" if defined $prompt; return $result; } @@ -416,10 +416,10 @@ sub check_valid { sub toDeclaration { my ($this) = @_; - my $name = lc $this->name; - my $result = $this->attribute('extra') . ";"; + my $extra = $this->attribute('extra'); + my $result = sprintf " %-32s", "$extra;"; my $prompt = $this->attribute('prompt'); - $result .= "\t/* $prompt */" if defined $prompt; + $result .= "/* $prompt */" if defined $prompt; return $result; } diff --git a/src/dbHost/DBD/Recordtype.pm b/src/dbHost/DBD/Recordtype.pm index 3160a70f2..dd361ce47 100644 --- a/src/dbHost/DBD/Recordtype.pm +++ b/src/dbHost/DBD/Recordtype.pm @@ -79,8 +79,8 @@ sub toDeclaration { } $this->fields; my $name = $this->name; $name .= "Record" unless $name eq "dbCommon"; - return "typedef struct $name {\n\t" . - join("\n\t", @fields) . + return "typedef struct $name {\n" . + join("\n", @fields) . "\n} $name;\n"; } diff --git a/src/dbHost/dbToMenuH b/src/dbHost/dbToMenuH index 953160743..4f5b31748 100755 --- a/src/dbHost/dbToMenuH +++ b/src/dbHost/dbToMenuH @@ -48,6 +48,11 @@ if ($opt_D) { while (($name, $menu) = each %{$menus}) { print OUTFILE $menu->toDeclaration; } - print OUTFILE "\n#endif /* $guard_name */\n"; + print OUTFILE "\n#ifdef GEN_MENU_CHOICES\n\n"; + while (($name, $menu) = each %{$menus}) { + print OUTFILE $menu->toDefinition; + } + print OUTFILE "\n#endif /* GEN_MENU_CHOICES */\n", + "#endif /* $guard_name */\n"; close OUTFILE; } diff --git a/src/dbHost/dbToRecordtypeH b/src/dbHost/dbToRecordtypeH index a009fec43..c4a2e2b78 100755 --- a/src/dbHost/dbToRecordtypeH +++ b/src/dbHost/dbToRecordtypeH @@ -49,12 +49,7 @@ if ($opt_D) { # Output dependencies only, to stdout print OUTFILE "/* $outfile generated from $infile */\n\n", "#ifndef $guard_name\n", "#define $guard_name\n\n", - "#include \"ellLib.h\"\n", - "#include \"epicsMutex.h\"\n", - "#include \"link.h\"\n", - "#include \"epicsTime.h\"\n", - "#include \"epicsTypes.h\"\n", - "#include \"epicsExport.h\"\n\n", + "#include \"recDecls.h\"\n\n", "#ifdef __cplusplus\n", "extern \"C\" {\n", "#endif\n\n"; @@ -69,18 +64,94 @@ if ($opt_D) { # Output dependencies only, to stdout print OUTFILE $rtyp->toDeclaration; unless ($rn eq 'dbCommon') { - print OUTFILE "\nenum {\n", - join(",\n", map { "\t${rn}Record$_" } $rtyp->field_names), - "\n};\n\n"; - + my $n=0; + print OUTFILE "\ntypedef enum {\n", + join(",\n", map { "\t${rn}Record$_ = " . $n++ } $rtyp->field_names), + "\n} ${rn}FieldIndex;\n\n"; print OUTFILE "#ifdef GEN_SIZE_OFFSET\n", - "static int ${rn}RecordSizeOffset(dbRecordType *pdbRecordType)\n", - "{\n"; - # ... FIXME: add size-offset data, etc. - print OUTFILE "}\n\n", - "epicsExportRegistrar(${rn}RecordSizeOffset);\n\n"; + join("\n", + map { "static const char ${rn}FieldName$_\[] = \"$_\";" } + $rtyp->field_names), + "\n\n"; + $n=0; + print OUTFILE "static const dbRecordData ${rn}RecordRecordData;\n\n", + "static dbFldDes ${rn}RecordFieldData[] = {\n", + join(",\n", map { + my $fn = $_->name; + " { ${rn}RecordFieldName$fn," . + $_->dbf_type . ',"' . + $_->attribute('initial') . '",' . + ($_->attribute('special') || '0') . ',' . + ($_->attribute('pp') || 'FALSE') . ',' . + ($_->attribute('interest') || '0') . ',' . + ($_->attribute('asl') || 'ASL0') . ',' . + $n++ . ",\n\t\&${rn}RecordRecordData," . + "GEOMETRY_DATA(${rn}Record," . lc($fn) . ') }'; + } $rtyp->fields), + "\n};\n\n"; + print OUTFILE "static const short ${rn}RecordFieldLinks[] = {\n", + join(",\n", map { + " ${rn}Record" . $_->name; + } grep { + $_->dbf_type =~ m/^DBF_(IN|OUT|FWD)LINK/; + } $rtyp->fields), + "\n};\n\n"; + my @sorted_names = sort $rtyp->field_names; + print OUTFILE "static const char * const ${rn}RecordFieldSortedNames[] = {\n", + join(",\n", map { + " ${rn}RecordFieldName$_" + } @sorted_names), + "\n};\n\n"; + print OUTFILE "static const short ${rn}RecordFieldSortedIndex[] = {\n", + join(",\n", map { + " ${rn}Record$_" + } @sorted_names), + "\n};\n\n"; + print OUTFILE "extern rset ${rn}RSET;\n\n", + "static const dbRecordData ${rn}RecordRecordData = {\n", + " \"$rn\",\n", + " sizeof(${rn}Record),\n", + " NELEMENTS(${rn}RecordFieldData),\n", + " ${rn}RecordFieldData,\n", + " ${rn}RecordVAL,\n", + " \&${rn}RecordFieldData[${rn}RecordVAL],\n", + " NELEMENTS(${rn}RecordFieldLinks),\n", + " ${rn}RecordFieldLinks,\n", + " ${rn}RecordFieldSortedNames,\n", + " ${rn}RecordFieldSortedIndex,\n", + " \&${rn}RSET\n", + "};\n\n"; + my @menu_fields = grep { + $_->dbf_type eq 'DBF_MENU' + } $rtyp->fields; + my %menu_uniq; + my @menu_names = grep { + !$menu_uniq{$_}++ + } map { + $_->attribute('menu') + } @menu_fields; + print OUTFILE join ("\n", map { + "extern dbMenu ${_}MenuData;" + } @menu_names), "\n\n"; + print OUTFILE "dbRecordType * ${rn}RecordRegistrar(dbBase *pbase, int nDevs)\n", + "{\n", + " dbRecordType *prt;\n"; + print OUTFILE map { + " dbRegisterMenu(pbase, \&${_}MenuData);\n" + } @menu_names; + print OUTFILE map { + " ${rn}RecordFieldData[${rn}Record" . + $_->name . + "].typDat.pmenu = \&" . + $_->attribute('menu') . + "MenuData;\n" + } @menu_fields; + # ... FIXME ... Missing prt, devMenu, CT_HEX/CT_DECIMAL + print OUTFILE " return prt;\n}\n\n", + "epicsExportRegistrar(${rn}RecordSizeOffset);\n", + "#endif\n"; } - print OUTFILE "#ifdef __cplusplus\n", + print OUTFILE "\n#ifdef __cplusplus\n", "} /* extern \"C\" */\n", "#endif\n\n", "#endif /* $guard_name */\n"; diff --git a/src/dbHost/macLib.pm b/src/dbHost/macLib.pm index 22020acc7..e4065483c 100644 --- a/src/dbHost/macLib.pm +++ b/src/dbHost/macLib.pm @@ -39,23 +39,8 @@ sub new ($@) { return $this; } -sub putValue ($$$) { - my ($this, $name, $raw) = @_; - if (exists $this->{macros}[0]{$name}) { - if (!defined $raw) { - delete $this->{macros}[0]{$name}; - } else { - $this->{macros}[0]{$name}{raw} = $raw; - } - } else { - my $entry = macLib::entry->new($name, 'macro'); - $entry->{raw} = $raw; - $this->{macros}[0]{$name} = $entry; - } - $this->{dirty} = 1; -} - sub installList ($@) { + # Argument is a list of strings which are arguments to installMacros my $this = shift; while (@_) { $this->installMacros(shift); @@ -63,11 +48,12 @@ sub installList ($@) { } sub installMacros ($$) { + # Argument is a string: a=1,b="2",c,d='hello' my $this = shift; $_ = shift; until (defined pos($_) and pos($_) == length($_)) { m/\G \s* /xgc; # Skip whitespace - if (m/\G ( \w+ ) \s* /xgc) { + if (m/\G ( [A-Za-z0-9_-]+ ) \s* /xgc) { my ($name, $val) = ($1); if (m/\G = \s* /xgc) { # The value follows, handle quotes and escapes @@ -93,6 +79,22 @@ sub installMacros ($$) { } } +sub putValue ($$$) { + my ($this, $name, $raw) = @_; + if (exists $this->{macros}[0]{$name}) { + if (!defined $raw) { + delete $this->{macros}[0]{$name}; + } else { + $this->{macros}[0]{$name}{raw} = $raw; + } + } else { + my $entry = macLib::entry->new($name, 'macro'); + $entry->{raw} = $raw; + $this->{macros}[0]{$name} = $entry; + } + $this->{dirty} = 1; +} + sub pushScope ($) { my ($this) = @_; unshift @{$this->{macros}}, {}; From 487596a2a841f94a4c709051778942a75208ca42 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 16:21:58 -0500 Subject: [PATCH 10/32] 2004-09-10: Updated menu definition stuff. --- src/dbHost/DBD/Menu.pm | 10 ++-- src/dbHost/dbToMenuH | 17 ++++-- src/dbHost/dbToRecordtypeH | 118 +++++++++++++++++++++---------------- 3 files changed, 84 insertions(+), 61 deletions(-) diff --git a/src/dbHost/DBD/Menu.pm b/src/dbHost/DBD/Menu.pm index a96690cdb..f91edb661 100644 --- a/src/dbHost/DBD/Menu.pm +++ b/src/dbHost/DBD/Menu.pm @@ -46,7 +46,7 @@ sub toDeclaration { return "typedef enum {\n" . join(",\n", @choices) . "\n\t${name}_NUM_CHOICES\n" . - "} $name;\n"; + "} $name;\n\n"; } sub toDefinition { @@ -55,10 +55,10 @@ sub toDefinition { my @strings = map { "\t\"" . escapeCstring(@{$_}[1]) . "\"" } $this->choices; - return "static const char * const ${name}MenuData = {\n" . - join(",\n", @strings) . "};\n\n" . - "dbMenu ${name}MenuData = {\n" . - "\t\"" . escapeCstring(name) . "\",\n" . + return "static const char * const ${name}ChoiceStrings = {\n" . + join(",\n", @strings) . "\n};\n" . + "const dbMenu ${name}MenuMetaData = {\n" . + "\t\"" . escapeCstring($name) . "\",\n" . "\t${name}_NUM_CHOICES,\n" . "\t${name}ChoiceStrings\n};\n"; } diff --git a/src/dbHost/dbToMenuH b/src/dbHost/dbToMenuH index 4f5b31748..da030f1c8 100755 --- a/src/dbHost/dbToMenuH +++ b/src/dbHost/dbToMenuH @@ -48,11 +48,16 @@ if ($opt_D) { while (($name, $menu) = each %{$menus}) { print OUTFILE $menu->toDeclaration; } - print OUTFILE "\n#ifdef GEN_MENU_CHOICES\n\n"; - while (($name, $menu) = each %{$menus}) { - print OUTFILE $menu->toDefinition; - } - print OUTFILE "\n#endif /* GEN_MENU_CHOICES */\n", - "#endif /* $guard_name */\n"; +# FIXME: Where to put metadata for widely used menus? +# In the generated menu.h file is wrong: can't create a list of menu.h files. +# Can only rely on registerRecordDeviceDriver output, so we must require that +# all such menus be named "menu...", and any other menus must be defined in +# the record.dbd file that needs them. +# print OUTFILE "\n#ifdef GEN_MENU_METADATA\n\n"; +# while (($name, $menu) = each %{$menus}) { +# print OUTFILE $menu->toDefinition; +# } +# print OUTFILE "\n#endif /* GEN_MENU_METADATA */\n"; + print OUTFILE "\n#endif /* $guard_name */\n"; close OUTFILE; } diff --git a/src/dbHost/dbToRecordtypeH b/src/dbHost/dbToRecordtypeH index c4a2e2b78..3d5d5c0e1 100755 --- a/src/dbHost/dbToRecordtypeH +++ b/src/dbHost/dbToRecordtypeH @@ -54,13 +54,30 @@ if ($opt_D) { # Output dependencies only, to stdout "extern \"C\" {\n", "#endif\n\n"; - my $menus = $dbd->menus; - while (($name, $menu) = each %{$menus}) { - print OUTFILE $menu->toDeclaration; - } - print OUTFILE "\n" if scalar %{$menus}; - my ($rn, $rtyp) = each %{$rtypes}; + + my @menu_fields = grep { + $_->dbf_type eq 'DBF_MENU' + } $rtyp->fields; + my %menu_used; + # We don't need @menus_used any more, but the %menu_used hash is set here + my @menus_used = grep { + !$menu_used{$_}++ + } map { + $_->attribute('menu') + } @menu_fields; + my $menus_defined = $dbd->menus; + while (($name, $menu) = each %{$menus_defined}) { + print OUTFILE $menu->toDeclaration; + if ($menu_used{$name}) { + delete $menu_used{$name} + } else { + warn "Menu '$name' defined but not used\n"; + } + } + my @menus_external = keys %menu_used; + print OUTFILE "\n" if scalar %{$menus_defined}; + print OUTFILE $rtyp->toDeclaration; unless ($rn eq 'dbCommon') { @@ -68,28 +85,33 @@ if ($opt_D) { # Output dependencies only, to stdout print OUTFILE "\ntypedef enum {\n", join(",\n", map { "\t${rn}Record$_ = " . $n++ } $rtyp->field_names), "\n} ${rn}FieldIndex;\n\n"; - print OUTFILE "#ifdef GEN_SIZE_OFFSET\n", - join("\n", - map { "static const char ${rn}FieldName$_\[] = \"$_\";" } - $rtyp->field_names), - "\n\n"; + print OUTFILE "#ifdef GEN_SIZE_OFFSET\n\n"; + print OUTFILE (map { + "extern const dbMenu ${_}MenuMetaData;\n" + } @menus_external), "\n"; + while (($name, $menu) = each %{$menus_defined}) { + print OUTFILE $menu->toDefinition, "\n"; + } + print OUTFILE (map { + "static const char ${rn}FieldName$_\[] = \"$_\";\n" } + $rtyp->field_names), "\n"; $n=0; - print OUTFILE "static const dbRecordData ${rn}RecordRecordData;\n\n", - "static dbFldDes ${rn}RecordFieldData[] = {\n", + print OUTFILE "static const dbRecordData ${rn}RecordMetaData;\n\n", + "static dbFldDes ${rn}FieldMetaData[] = {\n", join(",\n", map { my $fn = $_->name; - " { ${rn}RecordFieldName$fn," . + " { ${rn}FieldName$fn," . $_->dbf_type . ',"' . $_->attribute('initial') . '",' . ($_->attribute('special') || '0') . ',' . ($_->attribute('pp') || 'FALSE') . ',' . ($_->attribute('interest') || '0') . ',' . ($_->attribute('asl') || 'ASL0') . ',' . - $n++ . ",\n\t\&${rn}RecordRecordData," . + $n++ . ",\n\t\&${rn}RecordMetaData," . "GEOMETRY_DATA(${rn}Record," . lc($fn) . ') }'; } $rtyp->fields), "\n};\n\n"; - print OUTFILE "static const short ${rn}RecordFieldLinks[] = {\n", + print OUTFILE "static const ${rn}FieldIndex ${rn}RecordLinkFields[] = {\n", join(",\n", map { " ${rn}Record" . $_->name; } grep { @@ -97,59 +119,55 @@ if ($opt_D) { # Output dependencies only, to stdout } $rtyp->fields), "\n};\n\n"; my @sorted_names = sort $rtyp->field_names; - print OUTFILE "static const char * const ${rn}RecordFieldSortedNames[] = {\n", + print OUTFILE "static const char * const ${rn}RecordSortedFieldNames[] = {\n", join(",\n", map { - " ${rn}RecordFieldName$_" + " ${rn}FieldName$_" } @sorted_names), "\n};\n\n"; - print OUTFILE "static const short ${rn}RecordFieldSortedIndex[] = {\n", + print OUTFILE "static const ${rn}FieldIndex ${rn}RecordSortedFieldIndex[] = {\n", join(",\n", map { " ${rn}Record$_" } @sorted_names), "\n};\n\n"; print OUTFILE "extern rset ${rn}RSET;\n\n", - "static const dbRecordData ${rn}RecordRecordData = {\n", + "static const dbRecordData ${rn}RecordMetaData = {\n", " \"$rn\",\n", " sizeof(${rn}Record),\n", - " NELEMENTS(${rn}RecordFieldData),\n", - " ${rn}RecordFieldData,\n", + " NELEMENTS(${rn}FieldMetaData),\n", + " ${rn}FieldMetaData,\n", " ${rn}RecordVAL,\n", - " \&${rn}RecordFieldData[${rn}RecordVAL],\n", - " NELEMENTS(${rn}RecordFieldLinks),\n", - " ${rn}RecordFieldLinks,\n", - " ${rn}RecordFieldSortedNames,\n", - " ${rn}RecordFieldSortedIndex,\n", + " \&${rn}FieldMetaData[${rn}RecordVAL],\n", + " NELEMENTS(${rn}RecordLinkFields),\n", + " ${rn}RecordLinkFields,\n", + " ${rn}RecordSortedFieldNames,\n", + " ${rn}RecordSortedFieldIndex,\n", " \&${rn}RSET\n", "};\n\n"; - my @menu_fields = grep { - $_->dbf_type eq 'DBF_MENU' - } $rtyp->fields; - my %menu_uniq; - my @menu_names = grep { - !$menu_uniq{$_}++ - } map { - $_->attribute('menu') - } @menu_fields; - print OUTFILE join ("\n", map { - "extern dbMenu ${_}MenuData;" - } @menu_names), "\n\n"; - print OUTFILE "dbRecordType * ${rn}RecordRegistrar(dbBase *pbase, int nDevs)\n", + print OUTFILE "dbRecordType * epicsShareAPI ${rn}RecordRegistrar(dbBase *pbase, int nDevs)\n", "{\n", - " dbRecordType *prt;\n"; + " dbRecordType *prt = dbCreateRecordtype(&${rn}RecordMetaData, nDevs);\n"; + print OUTFILE " ${rn}FieldMetaData[${rn}RecordDTYP].typDat.pdevMenu = \&prt->devMenu;\n"; + while (($name, $menu) = each %{$menus_defined}) { + print OUTFILE " dbRegisterMenu(pbase, \&${name}MenuMetaData);\n"; + } print OUTFILE map { - " dbRegisterMenu(pbase, \&${_}MenuData);\n" - } @menu_names; - print OUTFILE map { - " ${rn}RecordFieldData[${rn}Record" . + " ${rn}FieldMetaData[${rn}Record" . $_->name . - "].typDat.pmenu = \&" . + "].typDat.pmenu = \n". + " \&" . $_->attribute('menu') . - "MenuData;\n" + "MenuMetaData;\n"; } @menu_fields; - # ... FIXME ... Missing prt, devMenu, CT_HEX/CT_DECIMAL + print OUTFILE map { + " ${rn}FieldMetaData[${rn}Record" . + $_->name . + "].typDat.base = CT_HEX;\n"; + } grep { + $_->attribute('base') eq 'HEX'; + } $rtyp->fields; + print OUTFILE " dbRegisterRecordtype(pbase, prt);\n"; print OUTFILE " return prt;\n}\n\n", - "epicsExportRegistrar(${rn}RecordSizeOffset);\n", - "#endif\n"; + "#endif /* GEN_SIZE_OFFSET */\n"; } print OUTFILE "\n#ifdef __cplusplus\n", "} /* extern \"C\" */\n", From cf421b7be956cd1ff659eaf43d0502b06a87f059 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 17:09:25 -0500 Subject: [PATCH 11/32] 2007-04-17: Added functionality for CDEFS. Still needs changes to dbToRecordtypeH. --- src/dbHost/DBD/Parser.pm | 4 ++++ src/dbHost/DBD/Recordtype.pm | 13 ++++++++++++- src/dbHost/test/Recordtype.pl | 8 +++++++- 3 files changed, 23 insertions(+), 2 deletions(-) diff --git a/src/dbHost/DBD/Parser.pm b/src/dbHost/DBD/Parser.pm index 7e8c21d29..376d66626 100644 --- a/src/dbHost/DBD/Parser.pm +++ b/src/dbHost/DBD/Parser.pm @@ -161,6 +161,10 @@ sub parse_recordtype { $dbd->add($rtyp); popContext("recordtype($name)"); return; + } + elsif (m/\G % (.*) \n/oxgc) { + print " Recordtype-Cdef: $1\n" if $debug; + $rtyp->add_cdef($1); } else { m/\G (.*) $/moxgc or dieContext("Unexpected end of input"); dieContext("Syntax error in '$1'"); diff --git a/src/dbHost/DBD/Recordtype.pm b/src/dbHost/DBD/Recordtype.pm index dd361ce47..0d0152d6d 100644 --- a/src/dbHost/DBD/Recordtype.pm +++ b/src/dbHost/DBD/Recordtype.pm @@ -11,6 +11,7 @@ sub init { $this->{FIELD_INDEX} = {}; $this->{DEVICE_LIST} = []; $this->{DEVICE_INDEX} = {}; + $this->{CDEFS} = []; return $this; } @@ -72,6 +73,15 @@ sub device { return $this->{DEVICE_INDEX}->{$choice}; } +sub add_cdef { + my ($this, $cdef) = @_; + push @{$this->{CDEFS}}, $cdef; +} + +sub cdefs { + return @{shift->{CDEFS}}; +} + sub toDeclaration { my $this = shift; my @fields = map { @@ -79,7 +89,8 @@ sub toDeclaration { } $this->fields; my $name = $this->name; $name .= "Record" unless $name eq "dbCommon"; - return "typedef struct $name {\n" . + my $cdefs = join("\n", $this->cdefs); + return "$cdefs\ntypedef struct $name {\n" . join("\n", @fields) . "\n} $name;\n"; } diff --git a/src/dbHost/test/Recordtype.pl b/src/dbHost/test/Recordtype.pl index a0545b8c0..b403ba103 100644 --- a/src/dbHost/test/Recordtype.pl +++ b/src/dbHost/test/Recordtype.pl @@ -1,6 +1,6 @@ #!/usr/bin/perl -use Test::More tests => 14; +use Test::More tests => 17; use DBD::Recordtype; use DBD::Recfield; @@ -46,3 +46,9 @@ is_deeply \@devices, [$dev1], 'Device list'; is $rtyp->device('test device'), $dev1, 'Device name lookup'; +is $rtyp->cdefs, 0, 'No cdefs yet'; +$rtyp->add_cdef("cdef"); +is $rtyp->cdefs, 1, 'First cdef added'; + +my @cdefs = $rtyp->cdefs; +is_deeply \@cdefs, ["cdef"], 'cdef list'; From f464b4d899e54308a0507916a2283d27ca15e751 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 17:09:59 -0500 Subject: [PATCH 12/32] 2007-04-19: Reorganized cdefs, C++ guard and some formatting. --- src/dbHost/DBD/Menu.pm | 6 +++--- src/dbHost/DBD/Recordtype.pm | 12 +++++++----- src/dbHost/dbToRecordtypeH | 28 ++++++++++++++-------------- src/dbHost/test/Menu.pl | 7 ++++++- src/dbHost/test/Recfield.pl | 18 +++++++++--------- 5 files changed, 39 insertions(+), 32 deletions(-) diff --git a/src/dbHost/DBD/Menu.pm b/src/dbHost/DBD/Menu.pm index f91edb661..61309f54d 100644 --- a/src/dbHost/DBD/Menu.pm +++ b/src/dbHost/DBD/Menu.pm @@ -45,7 +45,7 @@ sub toDeclaration { } $this->choices; return "typedef enum {\n" . join(",\n", @choices) . - "\n\t${name}_NUM_CHOICES\n" . + ",\n\t${name}_NUM_CHOICES\n" . "} $name;\n\n"; } @@ -55,12 +55,12 @@ sub toDefinition { my @strings = map { "\t\"" . escapeCstring(@{$_}[1]) . "\"" } $this->choices; - return "static const char * const ${name}ChoiceStrings = {\n" . + return "static const char * const ${name}ChoiceStrings[] = {\n" . join(",\n", @strings) . "\n};\n" . "const dbMenu ${name}MenuMetaData = {\n" . "\t\"" . escapeCstring($name) . "\",\n" . "\t${name}_NUM_CHOICES,\n" . - "\t${name}ChoiceStrings\n};\n"; + "\t${name}ChoiceStrings\n};\n\n"; } 1; diff --git a/src/dbHost/DBD/Recordtype.pm b/src/dbHost/DBD/Recordtype.pm index 0d0152d6d..f6571b7e0 100644 --- a/src/dbHost/DBD/Recordtype.pm +++ b/src/dbHost/DBD/Recordtype.pm @@ -64,8 +64,7 @@ sub add_device { } sub devices { - my $this = shift; - return @{$this->{DEVICE_LIST}}; + return @{shift->{DEVICE_LIST}}; } sub device { @@ -82,6 +81,10 @@ sub cdefs { return @{shift->{CDEFS}}; } +sub toCdefs { + return join("\n", shift->cdefs) . "\n\n"; +} + sub toDeclaration { my $this = shift; my @fields = map { @@ -89,10 +92,9 @@ sub toDeclaration { } $this->fields; my $name = $this->name; $name .= "Record" unless $name eq "dbCommon"; - my $cdefs = join("\n", $this->cdefs); - return "$cdefs\ntypedef struct $name {\n" . + return "typedef struct $name {\n" . join("\n", @fields) . - "\n} $name;\n"; + "\n} $name;\n\n"; } 1; diff --git a/src/dbHost/dbToRecordtypeH b/src/dbHost/dbToRecordtypeH index 3d5d5c0e1..190b669f4 100755 --- a/src/dbHost/dbToRecordtypeH +++ b/src/dbHost/dbToRecordtypeH @@ -48,20 +48,17 @@ if ($opt_D) { # Output dependencies only, to stdout open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n"; print OUTFILE "/* $outfile generated from $infile */\n\n", "#ifndef $guard_name\n", - "#define $guard_name\n\n", - "#include \"recDecls.h\"\n\n", - "#ifdef __cplusplus\n", - "extern \"C\" {\n", - "#endif\n\n"; + "#define $guard_name\n\n"; my ($rn, $rtyp) = each %{$rtypes}; + print OUTFILE $rtyp->toCdefs; + my @menu_fields = grep { $_->dbf_type eq 'DBF_MENU' } $rtyp->fields; my %menu_used; - # We don't need @menus_used any more, but the %menu_used hash is set here - my @menus_used = grep { + grep { !$menu_used{$_}++ } map { $_->attribute('menu') @@ -76,13 +73,12 @@ if ($opt_D) { # Output dependencies only, to stdout } } my @menus_external = keys %menu_used; - print OUTFILE "\n" if scalar %{$menus_defined}; print OUTFILE $rtyp->toDeclaration; unless ($rn eq 'dbCommon') { my $n=0; - print OUTFILE "\ntypedef enum {\n", + print OUTFILE "typedef enum {\n", join(",\n", map { "\t${rn}Record$_ = " . $n++ } $rtyp->field_names), "\n} ${rn}FieldIndex;\n\n"; print OUTFILE "#ifdef GEN_SIZE_OFFSET\n\n"; @@ -90,7 +86,7 @@ if ($opt_D) { # Output dependencies only, to stdout "extern const dbMenu ${_}MenuMetaData;\n" } @menus_external), "\n"; while (($name, $menu) = each %{$menus_defined}) { - print OUTFILE $menu->toDefinition, "\n"; + print OUTFILE $menu->toDefinition; } print OUTFILE (map { "static const char ${rn}FieldName$_\[] = \"$_\";\n" } @@ -142,7 +138,10 @@ if ($opt_D) { # Output dependencies only, to stdout " ${rn}RecordSortedFieldNames,\n", " ${rn}RecordSortedFieldIndex,\n", " \&${rn}RSET\n", - "};\n\n"; + "};\n\n", + "#ifdef __cplusplus\n", + "extern \"C\" {\n", + "#endif\n\n"; print OUTFILE "dbRecordType * epicsShareAPI ${rn}RecordRegistrar(dbBase *pbase, int nDevs)\n", "{\n", " dbRecordType *prt = dbCreateRecordtype(&${rn}RecordMetaData, nDevs);\n"; @@ -167,11 +166,12 @@ if ($opt_D) { # Output dependencies only, to stdout } $rtyp->fields; print OUTFILE " dbRegisterRecordtype(pbase, prt);\n"; print OUTFILE " return prt;\n}\n\n", + "#ifdef __cplusplus\n", + "} /* extern \"C\" */\n", + "#endif\n\n", "#endif /* GEN_SIZE_OFFSET */\n"; } - print OUTFILE "\n#ifdef __cplusplus\n", - "} /* extern \"C\" */\n", - "#endif\n\n", + print OUTFILE "\n", "#endif /* $guard_name */\n"; close OUTFILE; } diff --git a/src/dbHost/test/Menu.pl b/src/dbHost/test/Menu.pl index a2ea7f764..dc6db9841 100644 --- a/src/dbHost/test/Menu.pl +++ b/src/dbHost/test/Menu.pl @@ -21,4 +21,9 @@ 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'; +like $menu->toDeclaration, qr/ ^ + \s* typedef \s+ enum \s+ { + \s+ ch1 \s+ \/\* [^*]* \*\/, + \s+ ch2 \s+ \/\* [^*]* \*\/, + \s+ test_NUM_CHOICES ,? + \s+ } \s+ test; \s* $ /x, 'C declaration'; diff --git a/src/dbHost/test/Recfield.pl b/src/dbHost/test/Recfield.pl index d88d11a68..92833ecd3 100644 --- a/src/dbHost/test/Recfield.pl +++ b/src/dbHost/test/Recfield.pl @@ -14,7 +14,7 @@ is keys %{$fld_string->attributes}, 1, "Size set"; ok $fld_string->legal_value("Hello, world!"), 'Legal value'; ok !$fld_string->legal_value("x"x41), 'Illegal string'; $fld_string->check_valid; -is $fld_string->toDeclaration, "char str[41];", "C declaration"; +like $fld_string->toDeclaration, qr/^\s*char\s+str\[41\];\s*$/, "C declaration"; my $fld_char = DBD::Recfield->new('chr', 'DBF_CHAR'); isa_ok $fld_char, 'DBD::Recfield'; @@ -26,7 +26,7 @@ ok $fld_char->legal_value("-128"), 'Legal - value'; ok $fld_char->legal_value("127"), 'Legal + value'; ok !$fld_char->legal_value("0x80"), 'Illegal + hex value'; $fld_char->check_valid; -is $fld_char->toDeclaration, "signed char chr;", "C declaration"; +like $fld_char->toDeclaration, qr/^\s*signed\s+char\s+chr;\s*$/, "C declaration"; my $fld_uchar = DBD::Recfield->new('uchr', 'DBF_UCHAR'); isa_ok $fld_uchar, 'DBD::Recfield'; @@ -38,7 +38,7 @@ ok $fld_uchar->legal_value("0"), 'Legal 0 value'; ok $fld_uchar->legal_value("0377"), 'Legal + value'; ok !$fld_uchar->legal_value("0400"), 'Illegal + octal value'; $fld_uchar->check_valid; -is $fld_uchar->toDeclaration, "unsigned char uchr;", "C declaration"; +like $fld_uchar->toDeclaration, qr/^\s*unsigned\s+char\s+uchr;\s*$/, "C declaration"; my $fld_short = DBD::Recfield->new('shrt', 'DBF_SHORT'); isa_ok $fld_short, 'DBD::Recfield'; @@ -50,7 +50,7 @@ ok $fld_short->legal_value("-32768"), 'Legal - value'; ok $fld_short->legal_value("32767"), 'Legal + value'; ok !$fld_short->legal_value("0x8000"), 'Illegal + hex value'; $fld_short->check_valid; -is $fld_short->toDeclaration, "signed short shrt;", "C declaration"; +like $fld_short->toDeclaration, qr/^\s*short\s+shrt;\s*$/, "C declaration"; my $fld_ushort = DBD::Recfield->new('ushrt', 'DBF_USHORT'); isa_ok $fld_ushort, 'DBD::Recfield'; @@ -62,7 +62,7 @@ ok $fld_ushort->legal_value("0"), 'Legal 0 value'; ok $fld_ushort->legal_value("65535"), 'Legal + value'; ok !$fld_ushort->legal_value("0x10000"), 'Illegal + hex value'; $fld_ushort->check_valid; -is $fld_ushort->toDeclaration, "unsigned short ushrt;", "C declaration"; +like $fld_ushort->toDeclaration, qr/^\s*unsigned\s+short\s+ushrt;\s*$/, "C declaration"; my $fld_long = DBD::Recfield->new('lng', 'DBF_LONG'); isa_ok $fld_long, 'DBD::Recfield'; @@ -73,7 +73,7 @@ ok $fld_long->legal_value("-12345678"), 'Legal - value'; ok $fld_long->legal_value("0x12345678"), 'Legal + value'; ok !$fld_long->legal_value("0xfigure"), 'Illegal value'; $fld_long->check_valid; -is $fld_long->toDeclaration, "epicsInt32 lng;", "C declaration"; +like $fld_long->toDeclaration, qr/^\s*epicsInt32\s+lng;\s*$/, "C declaration"; my $fld_ulong = DBD::Recfield->new('ulng', 'DBF_ULONG'); isa_ok $fld_ulong, 'DBD::Recfield'; @@ -85,7 +85,7 @@ ok $fld_ulong->legal_value("00"), 'Legal 0 value'; ok $fld_ulong->legal_value("0xffffffff"), 'Legal + value'; ok !$fld_ulong->legal_value("0xfacepaint"), 'Illegal value'; $fld_ulong->check_valid; -is $fld_ulong->toDeclaration, "unsigned long ulng;", "C declaration"; +like $fld_ulong->toDeclaration, qr/^\s*unsigned\s+long\s+ulng;\s*$/, "C declaration"; my $fld_float = DBD::Recfield->new('flt', 'DBF_FLOAT'); isa_ok $fld_float, 'DBD::Recfield'; @@ -96,7 +96,7 @@ ok $fld_float->legal_value("-1.2345678e9"), 'Legal - value'; ok $fld_float->legal_value("0.12345678e9"), 'Legal + value'; ok !$fld_float->legal_value("0x1.5"), 'Illegal value'; $fld_float->check_valid; -is $fld_float->toDeclaration, "float flt;", "C declaration"; +like $fld_float->toDeclaration, qr/^\s*float\s+flt;\s*$/, "C declaration"; my $fld_double = DBD::Recfield->new('dbl', 'DBF_DOUBLE'); isa_ok $fld_double, 'DBD::Recfield'; @@ -107,5 +107,5 @@ ok $fld_double->legal_value("-12345e-67"), 'Legal - value'; ok $fld_double->legal_value("12345678e+9"), 'Legal + value'; ok !$fld_double->legal_value("e5"), 'Illegal value'; $fld_double->check_valid; -is $fld_double->toDeclaration, "double dbl;", "C declaration"; +like $fld_double->toDeclaration, qr/^\s*double\s+dbl;\s*$/, "C declaration"; From 68e0fba01b3da2a2aefba60e8cea3d5f3fbd797a Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 17:23:32 -0500 Subject: [PATCH 13/32] 2009-02-08: Work with & match R3.14.10 output; rename tools. --- src/dbHost/DBD/Menu.pm | 4 +- src/dbHost/DBD/Recfield.pm | 16 +- src/dbHost/Makefile | 30 ++++ src/dbHost/{dbExpand => dbExpand.pl} | 5 +- src/dbHost/dbToRecordtypeH | 177 ------------------- src/dbHost/{dbToMenuH => dbdToMenuH.pl} | 19 +- src/dbHost/dbdToRecordtypeH.pl | 222 ++++++++++++++++++++++++ 7 files changed, 280 insertions(+), 193 deletions(-) create mode 100644 src/dbHost/Makefile rename src/dbHost/{dbExpand => dbExpand.pl} (93%) delete mode 100755 src/dbHost/dbToRecordtypeH rename src/dbHost/{dbToMenuH => dbdToMenuH.pl} (81%) create mode 100755 src/dbHost/dbdToRecordtypeH.pl diff --git a/src/dbHost/DBD/Menu.pm b/src/dbHost/DBD/Menu.pm index 61309f54d..ec59e8567 100644 --- a/src/dbHost/DBD/Menu.pm +++ b/src/dbHost/DBD/Menu.pm @@ -41,11 +41,11 @@ sub toDeclaration { my $this = shift; my $name = $this->name; my @choices = map { - "\t" . @{$_}[0] . "\t/* " . escapeCcomment(@{$_}[1]) . " */" + sprintf " %-31s /* %s */", @{$_}[0], escapeCcomment(@{$_}[1]); } $this->choices; return "typedef enum {\n" . join(",\n", @choices) . - ",\n\t${name}_NUM_CHOICES\n" . + ",\n ${name}_NUM_CHOICES\n" . "} $name;\n\n"; } diff --git a/src/dbHost/DBD/Recfield.pm b/src/dbHost/DBD/Recfield.pm index 9b3b76ee6..2b3e38089 100644 --- a/src/dbHost/DBD/Recfield.pm +++ b/src/dbHost/DBD/Recfield.pm @@ -156,7 +156,7 @@ sub legal_value { } sub toDeclaration { - return shift->SUPER::toDeclaration("signed char"); + return shift->SUPER::toDeclaration("epicsInt8"); } @@ -176,7 +176,7 @@ sub legal_value { } sub toDeclaration { - return shift->SUPER::toDeclaration("unsigned char"); + return shift->SUPER::toDeclaration("epicsUInt8"); } @@ -196,7 +196,7 @@ sub legal_value { } sub toDeclaration { - return shift->SUPER::toDeclaration("short"); + return shift->SUPER::toDeclaration("epicsInt16"); } @@ -216,7 +216,7 @@ sub legal_value { } sub toDeclaration { - return shift->SUPER::toDeclaration("unsigned short"); + return shift->SUPER::toDeclaration("epicsUInt16"); } @@ -253,7 +253,7 @@ sub legal_value { } sub toDeclaration { - return shift->SUPER::toDeclaration("unsigned long"); + return shift->SUPER::toDeclaration("epicsUInt32"); } @@ -270,7 +270,7 @@ sub legal_value { } sub toDeclaration { - return shift->SUPER::toDeclaration("float"); + return shift->SUPER::toDeclaration("epicsFloat32"); } @@ -287,7 +287,7 @@ sub legal_value { } sub toDeclaration { - return shift->SUPER::toDeclaration("double"); + return shift->SUPER::toDeclaration("epicsFloat64"); } @@ -417,7 +417,7 @@ sub check_valid { sub toDeclaration { my ($this) = @_; my $extra = $this->attribute('extra'); - my $result = sprintf " %-32s", "$extra;"; + my $result = sprintf " %-31s ", "$extra;"; my $prompt = $this->attribute('prompt'); $result .= "/* $prompt */" if defined $prompt; return $result; diff --git a/src/dbHost/Makefile b/src/dbHost/Makefile new file mode 100644 index 000000000..03f17cc85 --- /dev/null +++ b/src/dbHost/Makefile @@ -0,0 +1,30 @@ +#************************************************************************* +# Copyright (c) 2009 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. +#************************************************************************* +TOP=../.. +include $(TOP)/configure/CONFIG + +PERL_MODULES += macLib.pm +PERL_MODULES += Readfile.pm +PERL_MODULES += DBD.pm +PERL_MODULES += DBD/Base.pm +PERL_MODULES += DBD/Breaktable.pm +PERL_MODULES += DBD/Device.pm +PERL_MODULES += DBD/Driver.pm +PERL_MODULES += DBD/Function.pm +PERL_MODULES += DBD/Menu.pm +PERL_MODULES += DBD/Parser.pm +PERL_MODULES += DBD/Recfield.pm +PERL_MODULES += DBD/Recordtype.pm +PERL_MODULES += DBD/Registrar.pm +PERL_MODULES += DBD/Variable.pm + +PERL_SCRIPTS += dbdToMenuH.pl +PERL_SCRIPTS += dbdToRecordtypeH.pl +PERL_SCRIPTS += dbExpand.pl + +include $(TOP)/configure/RULES + diff --git a/src/dbHost/dbExpand b/src/dbHost/dbExpand.pl similarity index 93% rename from src/dbHost/dbExpand rename to src/dbHost/dbExpand.pl index d70a594a1..5ff79e58b 100755 --- a/src/dbHost/dbExpand +++ b/src/dbHost/dbExpand.pl @@ -4,7 +4,10 @@ # duplicate definitions, unlike the dbStaticLib version. It does do the # include file expansion and macro substitution though. -use Getopts; +use FindBin qw($Bin); +use lib "$Bin/../../lib/perl"; + +use EPICS::Getopts; use Readfile; use macLib; diff --git a/src/dbHost/dbToRecordtypeH b/src/dbHost/dbToRecordtypeH deleted file mode 100755 index 190b669f4..000000000 --- a/src/dbHost/dbToRecordtypeH +++ /dev/null @@ -1,177 +0,0 @@ -#!/usr/bin/perl - -use DBD; -use DBD::Parser; -use Getopts; -use macLib; -use Readfile; - -my $tool = 'dbToRecordtypeH'; -getopts('DI@o:') or - die "Usage: $tool [-D] [-I dir] [-o xRecord.h] xRecord.dbd [xRecord.h]\n"; - -my @path = map { split /[:;]/ } @opt_I; -my $dbd = DBD->new(); - -my $infile = shift @ARGV; -$infile =~ m/\.dbd$/ or - die "$tool: Input file '$infile' must have '.dbd' extension\n"; - -my $outfile; -if ($opt_o) { - $outfile = $opt_o; -} elsif (@ARGV) { - $outfile = shift @ARGV; -} else { - ($outfile = $infile) =~ s/\.dbd$/.h/; - $outfile =~ s/^.*\///; - $outfile =~ s/dbCommonRecord/dbCommon/; -} - -# Derive a name for the include guard -my $guard_name = "INC_$outfile"; -$guard_name =~ tr/a-zA-Z0-9_/_/cs; -$guard_name =~ s/(_[hH])?$/_H/; - -&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I)); - -my $rtypes = $dbd->recordtypes; -die "$tool: Input file must contain a single recordtype definition.\n" - unless (1 == keys %{$rtypes}); - -if ($opt_D) { # Output dependencies only, to stdout - my %filecount; - my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles; - print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n"; - print map { "$_:\n" } @uniqfiles; -} else { - open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n"; - print OUTFILE "/* $outfile generated from $infile */\n\n", - "#ifndef $guard_name\n", - "#define $guard_name\n\n"; - - my ($rn, $rtyp) = each %{$rtypes}; - - print OUTFILE $rtyp->toCdefs; - - my @menu_fields = grep { - $_->dbf_type eq 'DBF_MENU' - } $rtyp->fields; - my %menu_used; - grep { - !$menu_used{$_}++ - } map { - $_->attribute('menu') - } @menu_fields; - my $menus_defined = $dbd->menus; - while (($name, $menu) = each %{$menus_defined}) { - print OUTFILE $menu->toDeclaration; - if ($menu_used{$name}) { - delete $menu_used{$name} - } else { - warn "Menu '$name' defined but not used\n"; - } - } - my @menus_external = keys %menu_used; - - print OUTFILE $rtyp->toDeclaration; - - unless ($rn eq 'dbCommon') { - my $n=0; - print OUTFILE "typedef enum {\n", - join(",\n", map { "\t${rn}Record$_ = " . $n++ } $rtyp->field_names), - "\n} ${rn}FieldIndex;\n\n"; - print OUTFILE "#ifdef GEN_SIZE_OFFSET\n\n"; - print OUTFILE (map { - "extern const dbMenu ${_}MenuMetaData;\n" - } @menus_external), "\n"; - while (($name, $menu) = each %{$menus_defined}) { - print OUTFILE $menu->toDefinition; - } - print OUTFILE (map { - "static const char ${rn}FieldName$_\[] = \"$_\";\n" } - $rtyp->field_names), "\n"; - $n=0; - print OUTFILE "static const dbRecordData ${rn}RecordMetaData;\n\n", - "static dbFldDes ${rn}FieldMetaData[] = {\n", - join(",\n", map { - my $fn = $_->name; - " { ${rn}FieldName$fn," . - $_->dbf_type . ',"' . - $_->attribute('initial') . '",' . - ($_->attribute('special') || '0') . ',' . - ($_->attribute('pp') || 'FALSE') . ',' . - ($_->attribute('interest') || '0') . ',' . - ($_->attribute('asl') || 'ASL0') . ',' . - $n++ . ",\n\t\&${rn}RecordMetaData," . - "GEOMETRY_DATA(${rn}Record," . lc($fn) . ') }'; - } $rtyp->fields), - "\n};\n\n"; - print OUTFILE "static const ${rn}FieldIndex ${rn}RecordLinkFields[] = {\n", - join(",\n", map { - " ${rn}Record" . $_->name; - } grep { - $_->dbf_type =~ m/^DBF_(IN|OUT|FWD)LINK/; - } $rtyp->fields), - "\n};\n\n"; - my @sorted_names = sort $rtyp->field_names; - print OUTFILE "static const char * const ${rn}RecordSortedFieldNames[] = {\n", - join(",\n", map { - " ${rn}FieldName$_" - } @sorted_names), - "\n};\n\n"; - print OUTFILE "static const ${rn}FieldIndex ${rn}RecordSortedFieldIndex[] = {\n", - join(",\n", map { - " ${rn}Record$_" - } @sorted_names), - "\n};\n\n"; - print OUTFILE "extern rset ${rn}RSET;\n\n", - "static const dbRecordData ${rn}RecordMetaData = {\n", - " \"$rn\",\n", - " sizeof(${rn}Record),\n", - " NELEMENTS(${rn}FieldMetaData),\n", - " ${rn}FieldMetaData,\n", - " ${rn}RecordVAL,\n", - " \&${rn}FieldMetaData[${rn}RecordVAL],\n", - " NELEMENTS(${rn}RecordLinkFields),\n", - " ${rn}RecordLinkFields,\n", - " ${rn}RecordSortedFieldNames,\n", - " ${rn}RecordSortedFieldIndex,\n", - " \&${rn}RSET\n", - "};\n\n", - "#ifdef __cplusplus\n", - "extern \"C\" {\n", - "#endif\n\n"; - print OUTFILE "dbRecordType * epicsShareAPI ${rn}RecordRegistrar(dbBase *pbase, int nDevs)\n", - "{\n", - " dbRecordType *prt = dbCreateRecordtype(&${rn}RecordMetaData, nDevs);\n"; - print OUTFILE " ${rn}FieldMetaData[${rn}RecordDTYP].typDat.pdevMenu = \&prt->devMenu;\n"; - while (($name, $menu) = each %{$menus_defined}) { - print OUTFILE " dbRegisterMenu(pbase, \&${name}MenuMetaData);\n"; - } - print OUTFILE map { - " ${rn}FieldMetaData[${rn}Record" . - $_->name . - "].typDat.pmenu = \n". - " \&" . - $_->attribute('menu') . - "MenuMetaData;\n"; - } @menu_fields; - print OUTFILE map { - " ${rn}FieldMetaData[${rn}Record" . - $_->name . - "].typDat.base = CT_HEX;\n"; - } grep { - $_->attribute('base') eq 'HEX'; - } $rtyp->fields; - print OUTFILE " dbRegisterRecordtype(pbase, prt);\n"; - print OUTFILE " return prt;\n}\n\n", - "#ifdef __cplusplus\n", - "} /* extern \"C\" */\n", - "#endif\n\n", - "#endif /* GEN_SIZE_OFFSET */\n"; - } - print OUTFILE "\n", - "#endif /* $guard_name */\n"; - close OUTFILE; -} diff --git a/src/dbHost/dbToMenuH b/src/dbHost/dbdToMenuH.pl similarity index 81% rename from src/dbHost/dbToMenuH rename to src/dbHost/dbdToMenuH.pl index da030f1c8..e321bc336 100755 --- a/src/dbHost/dbToMenuH +++ b/src/dbHost/dbdToMenuH.pl @@ -1,12 +1,19 @@ #!/usr/bin/perl +# $Id$ +use FindBin qw($Bin); +use lib "$Bin/../../lib/perl"; + +use EPICS::Getopts; +use File::Basename; use DBD; use DBD::Parser; -use Getopts; use macLib; use Readfile; -my $tool = 'dbToMenuH'; +my $tool = 'dbdToMenuH.pl'; + +use vars qw($opt_D @opt_I $opt_o $opt_s); getopts('DI@o:') or die "Usage: $tool: [-D] [-I dir] [-o menu.h] menu.dbd [menu.h]\n"; @@ -16,6 +23,7 @@ my $dbd = DBD->new(); my $infile = shift @ARGV; $infile =~ m/\.dbd$/ or die "$tool: Input file '$infile' must have '.dbd' extension\n"; +my $inbase = basename($infile); my $outfile; if ($opt_o) { @@ -26,9 +34,10 @@ if ($opt_o) { ($outfile = $infile) =~ s/\.dbd$/.h/; $outfile =~ s/^.*\///; } +my $outbase = basename($outfile); # Derive a name for the include guard -my $guard_name = "INC_$outfile"; +my $guard_name = "INC_$outbase"; $guard_name =~ tr/a-zA-Z0-9_/_/cs; $guard_name =~ s/(_[hH])?$/_H/; @@ -41,11 +50,11 @@ if ($opt_D) { print map { "$_:\n" } @uniqfiles; } else { open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n"; - print OUTFILE "/* $outfile generated from $infile */\n\n", + print OUTFILE "/* $outbase generated from $inbase */\n\n", "#ifndef $guard_name\n", "#define $guard_name\n\n"; my $menus = $dbd->menus; - while (($name, $menu) = each %{$menus}) { + while (my ($name, $menu) = each %{$menus}) { print OUTFILE $menu->toDeclaration; } # FIXME: Where to put metadata for widely used menus? diff --git a/src/dbHost/dbdToRecordtypeH.pl b/src/dbHost/dbdToRecordtypeH.pl new file mode 100755 index 000000000..0850b6e2a --- /dev/null +++ b/src/dbHost/dbdToRecordtypeH.pl @@ -0,0 +1,222 @@ +#!/usr/bin/perl +# $Id$ + +use FindBin qw($Bin); +use lib "$Bin/../../lib/perl"; + +use EPICS::Getopts; +use File::Basename; +use DBD; +use DBD::Parser; +use macLib; +use Readfile; + +my $tool = 'dbdToRecordtypeH.pl'; + +use vars qw($opt_D @opt_I $opt_o $opt_s); +getopts('DI@o:s') or + die "Usage: $tool [-D] [-I dir] [-o xRecord.h] xRecord.dbd [xRecord.h]\n"; + +my @path = map { split /[:;]/ } @opt_I; +my $dbd = DBD->new(); + +my $infile = shift @ARGV; +$infile =~ m/\.dbd$/ or + die "$tool: Input file '$infile' must have '.dbd' extension\n"; +my $inbase = basename($infile); + +my $outfile; +if ($opt_o) { + $outfile = $opt_o; +} elsif (@ARGV) { + $outfile = shift @ARGV; +} else { + ($outfile = $infile) =~ s/\.dbd$/.h/; + $outfile =~ s/^.*\///; + $outfile =~ s/dbCommonRecord/dbCommon/; +} +my $outbase = basename($outfile); + +# Derive a name for the include guard +my $guard_name = "INC_$outbase"; +$guard_name =~ tr/a-zA-Z0-9_/_/cs; +$guard_name =~ s/(_[hH])?$/_H/; + +&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I)); + +my $rtypes = $dbd->recordtypes; +die "$tool: Input file must contain a single recordtype definition.\n" + unless (1 == keys %{$rtypes}); + +if ($opt_D) { # Output dependencies only, to stdout + my %filecount; + my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles; + print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n"; + print map { "$_:\n" } @uniqfiles; +} else { + open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n"; + print OUTFILE "/* $outbase generated from $inbase */\n\n", + "#ifndef $guard_name\n", + "#define $guard_name\n\n"; + + our ($rn, $rtyp) = each %{$rtypes}; + + print OUTFILE $rtyp->toCdefs; + + my @menu_fields = grep { + $_->dbf_type eq 'DBF_MENU' + } $rtyp->fields; + my %menu_used; + grep { + !$menu_used{$_}++ + } map { + $_->attribute('menu') + } @menu_fields; + our $menus_defined = $dbd->menus; + while (my ($name, $menu) = each %{$menus_defined}) { + print OUTFILE $menu->toDeclaration; + if ($menu_used{$name}) { + delete $menu_used{$name} + } else { + warn "Menu '$name' defined but not used\n"; + } + } + our @menus_external = keys %menu_used; + + print OUTFILE $rtyp->toDeclaration; + + unless ($rn eq 'dbCommon') { + my $n = 0; + print OUTFILE "typedef enum {\n", + join(",\n", + map { "\t${rn}Record$_ = " . $n++ } $rtyp->field_names), + "\n} ${rn}FieldIndex;\n\n"; + print OUTFILE "#ifdef GEN_SIZE_OFFSET\n\n"; + if ($opt_s) { + &newtables; + } else { + &oldtables; + } + print OUTFILE "#endif /* GEN_SIZE_OFFSET */\n"; + } + print OUTFILE "\n", + "#endif /* $guard_name */\n"; + close OUTFILE; +} + +sub oldtables { + # Output compatible with R3.14.x + print OUTFILE "#ifdef __cplusplus\n" . + "extern \"C\" {\n" . + "#endif\n" . + "#include \n" . + "static int ${rn}RecordSizeOffset(dbRecordType *prt)\n" . + "{\n" . + " ${rn}Record *prec = 0;\n" . + join("\n", map { + " prt->papFldDes[${rn}Record$_]->size = " . + "sizeof(prec->" . lc($_) . ");" + } $rtyp->field_names) . "\n" . + join("\n", map { + " prt->papFldDes[${rn}Record$_]->offset = " . + "(char *)&prec->" . lc($_) . " - (char *)prec;" + } $rtyp->field_names) . "\n" . + " prt->rec_size = sizeof(*prec);\n" . + " return 0;\n" . + "}\n" . + "epicsExportRegistrar(${rn}RecordSizeOffset);\n\n" . + "#ifdef __cplusplus\n" . + "}\n" . + "#endif\n"; +} + +sub newtables { + # Output for an eventual DBD-less IOC + print OUTFILE (map { + "extern const dbMenu ${_}MenuMetaData;\n" + } @menus_external), "\n"; + while (my ($name, $menu) = each %{$menus_defined}) { + print OUTFILE $menu->toDefinition; + } + print OUTFILE (map { + "static const char ${rn}FieldName$_\[] = \"$_\";\n" } + $rtyp->field_names), "\n"; + my $n = 0; + print OUTFILE "static const dbRecordData ${rn}RecordMetaData;\n\n", + "static dbFldDes ${rn}FieldMetaData[] = {\n", + join(",\n", map { + my $fn = $_->name; + " { ${rn}FieldName${fn}," . + $_->dbf_type . ',"' . + $_->attribute('initial') . '",' . + ($_->attribute('special') || '0') . ',' . + ($_->attribute('pp') || 'FALSE') . ',' . + ($_->attribute('interest') || '0') . ',' . + ($_->attribute('asl') || 'ASL0') . ',' . + $n++ . ",\n\t\&${rn}RecordMetaData," . + "GEOMETRY_DATA(${rn}Record," . lc($fn) . ') }'; + } $rtyp->fields), + "\n};\n\n"; + print OUTFILE "static const ${rn}FieldIndex ${rn}RecordLinkFieldIndices[] = {\n", + join(",\n", map { + " ${rn}Record" . $_->name; + } grep { + $_->dbf_type =~ m/^DBF_(IN|OUT|FWD)LINK/; + } $rtyp->fields), + "\n};\n\n"; + my @sorted_names = sort $rtyp->field_names; + print OUTFILE "static const char * const ${rn}RecordSortedFieldNames[] = {\n", + join(",\n", map { + " ${rn}FieldName$_" + } @sorted_names), + "\n};\n\n"; + print OUTFILE "static const ${rn}FieldIndex ${rn}RecordSortedFieldIndices[] = {\n", + join(",\n", map { + " ${rn}Record$_" + } @sorted_names), + "\n};\n\n"; + print OUTFILE "extern rset ${rn}RSET;\n\n", + "static const dbRecordData ${rn}RecordMetaData = {\n", + " \"$rn\",\n", + " sizeof(${rn}Record),\n", + " NELEMENTS(${rn}FieldMetaData),\n", + " ${rn}FieldMetaData,\n", + " ${rn}RecordVAL,\n", + " \&${rn}FieldMetaData[${rn}RecordVAL],\n", + " NELEMENTS(${rn}RecordLinkFieldIndices),\n", + " ${rn}RecordLinkFieldIndices,\n", + " ${rn}RecordSortedFieldNames,\n", + " ${rn}RecordSortedFieldIndices,\n", + " \&${rn}RSET\n", + "};\n\n", + "#ifdef __cplusplus\n", + "extern \"C\" {\n", + "#endif\n\n"; + print OUTFILE "dbRecordType * epicsShareAPI ${rn}RecordRegistrar(dbBase *pbase, int nDevs)\n", + "{\n", + " dbRecordType *prt = dbCreateRecordtype(&${rn}RecordMetaData, nDevs);\n"; + print OUTFILE " ${rn}FieldMetaData[${rn}RecordDTYP].typDat.pdevMenu = \&prt->devMenu;\n"; + while (my ($name, $menu) = each %{$menus_defined}) { + print OUTFILE " dbRegisterMenu(pbase, \&${name}MenuMetaData);\n"; + } + print OUTFILE map { + " ${rn}FieldMetaData[${rn}Record" . + $_->name . + "].typDat.pmenu = \n". + " \&" . + $_->attribute('menu') . + "MenuMetaData;\n"; + } @menu_fields; + print OUTFILE map { + " ${rn}FieldMetaData[${rn}Record" . + $_->name . + "].typDat.base = CT_HEX;\n"; + } grep { + $_->attribute('base') eq 'HEX'; + } $rtyp->fields; + print OUTFILE " dbRegisterRecordtype(pbase, prt);\n"; + print OUTFILE " return prt;\n}\n\n", + "#ifdef __cplusplus\n", + "} /* extern \"C\" */\n", + "#endif\n\n"; +} From f804eb00e79b0f3f14e68d094c2cff1229b20756 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 17:27:41 -0500 Subject: [PATCH 14/32] 2009-02-15: Getting close. Rename dbExpand => dbdExpand, Added proper parsing and generation of DBD file. --- src/dbHost/DBD/Output.pm | 98 ++++++++++++++++++++++++++++++++++++++++ src/dbHost/Makefile | 3 +- src/dbHost/dbExpand.pl | 39 ---------------- src/dbHost/dbdExpand.pl | 44 ++++++++++++++++++ src/dbHost/dbdReport | 5 +- 5 files changed, 148 insertions(+), 41 deletions(-) create mode 100644 src/dbHost/DBD/Output.pm delete mode 100755 src/dbHost/dbExpand.pl create mode 100755 src/dbHost/dbdExpand.pl diff --git a/src/dbHost/DBD/Output.pm b/src/dbHost/DBD/Output.pm new file mode 100644 index 000000000..eaff9c45c --- /dev/null +++ b/src/dbHost/DBD/Output.pm @@ -0,0 +1,98 @@ +package DBD::Output; + +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(&OutputDBD); + +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; + +sub OutputDBD { + my ($out, $dbd) = @_; + &OutputMenus($out, $dbd->menus); + &OutputRecordtypes($out, $dbd->recordtypes); + &OutputDrivers($out, $dbd->drivers); + &OutputRegistrars($out, $dbd->registrars); + &OutputFunctions($out, $dbd->functions); + &OutputVariables($out, $dbd->variables); + &OutputBreaktables($out, $dbd->breaktables); +} + +sub OutputMenus { + my ($out, $menus) = @_; + while (my ($name, $menu) = each %{$menus}) { + printf $out "menu(%s) {\n", $name; + printf $out " choice(%s, \"%s\")\n", @{$_} + foreach $menu->choices; + print $out "}\n"; + } +} + +sub OutputRecordtypes { + my ($out, $recordtypes) = @_; + while (my ($name, $recordtype) = each %{$recordtypes}) { + printf $out "recordtype(%s) {\n", $name; + foreach $field ($recordtype->fields) { + printf $out " field(%s, %s) {\n", + $field->name, $field->dbf_type; + while (my ($attr, $val) = each %{$field->attributes}) { + $val = "\"$val\"" if $val =~ m/\s/; + printf $out " %s(%s)\n", $attr, $val; + } + print $out " }\n"; + } + print $out "% $_\n" + foreach $recordtype->cdefs; + printf $out "}\n"; + printf $out "device(%s, %s, %s, \"%s\")\n", + $name, $_->link_type, $_->name, $_->choice + foreach $recordtype->devices; + } +} + +sub OutputDrivers { + my ($out, $drivers) = @_; + printf $out "driver(%s)\n", $_ + foreach keys %{$drivers}; +} + +sub OutputRegistrars { + my ($out, $registrars) = @_; + printf $out "registrar(%s)\n", $_ + foreach keys %{$registrars}; +} + +sub OutputFunctions { + my ($out, $functions) = @_; + printf $out "function(%s)\n", $_ + foreach keys %{$functions}; +} + +sub OutputVariables { + my ($out, $variables) = @_; + while (my ($name, $variable) = each %{$variables}) { + printf $out "variable(%s, %s)\n", $name, $variable->var_type; + } +} + +sub OutputBreaktables { + my ($out, $breaktables) = @_; + while (my ($name, $breaktable) = each %{$breaktables}) { + printf $out "breaktable(\"%s\") {\n", $name; + printf $out " point(%s, %s)\n", @{$_} + foreach $breaktable->points; + print $out "}\n"; + } +} + +1; diff --git a/src/dbHost/Makefile b/src/dbHost/Makefile index 03f17cc85..0158ca2a5 100644 --- a/src/dbHost/Makefile +++ b/src/dbHost/Makefile @@ -16,6 +16,7 @@ PERL_MODULES += DBD/Device.pm PERL_MODULES += DBD/Driver.pm PERL_MODULES += DBD/Function.pm PERL_MODULES += DBD/Menu.pm +PERL_MODULES += DBD/Output.pm PERL_MODULES += DBD/Parser.pm PERL_MODULES += DBD/Recfield.pm PERL_MODULES += DBD/Recordtype.pm @@ -24,7 +25,7 @@ PERL_MODULES += DBD/Variable.pm PERL_SCRIPTS += dbdToMenuH.pl PERL_SCRIPTS += dbdToRecordtypeH.pl -PERL_SCRIPTS += dbExpand.pl +PERL_SCRIPTS += dbdExpand.pl include $(TOP)/configure/RULES diff --git a/src/dbHost/dbExpand.pl b/src/dbHost/dbExpand.pl deleted file mode 100755 index 5ff79e58b..000000000 --- a/src/dbHost/dbExpand.pl +++ /dev/null @@ -1,39 +0,0 @@ -#!/usr/bin/perl - -# This version of dbExpand does not syntax check its input files or remove -# duplicate definitions, unlike the dbStaticLib version. It does do the -# include file expansion and macro substitution though. - -use FindBin qw($Bin); -use lib "$Bin/../../lib/perl"; - -use EPICS::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 @output; - -my $macros = macLib->new(@opt_S); - -while (@ARGV) { - my @file = &Readfile(shift @ARGV, $macros, \@opt_I); - # Strip the stuff that Readfile() added: - push @output, grep !/^\#\#!/, @file -} - -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"; - print map { "$_:\n" } @uniqfiles; -} elsif ($opt_o) { - open OUTFILE, ">$opt_o" or die "Can't create $opt_o: $!\n"; - print OUTFILE @output; - close OUTFILE; -} else { - print @output; -} diff --git a/src/dbHost/dbdExpand.pl b/src/dbHost/dbdExpand.pl new file mode 100755 index 000000000..5919ddbe4 --- /dev/null +++ b/src/dbHost/dbdExpand.pl @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use FindBin qw($Bin); +use lib "$Bin/../../lib/perl"; + +use DBD; +use DBD::Parser; +use DBD::Output; +use EPICS::Getopts; +use Readfile; +use macLib; + +getopts('DI@S@o:') or + die "Usage: dbdExpand [-D] [-I dir] [-S macro=val] [-o out.dbd] in.dbd ..."; + +my @path = map { split /[:;]/ } @opt_I; +my $macros = macLib->new(@opt_S); +my $dbd = DBD->new(); + +while (@ARGV) { + &ParseDBD($dbd, &Readfile(shift @ARGV, $macros, \@opt_I)); +} + +if ($opt_D) { # Output dependencies only + my %filecount; + my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles; + print "$opt_o: ", join(" \\\n ", @uniqfiles), "\n\n"; + print map { "$_:\n" } @uniqfiles; + exit 0; +} + +my $out; +if ($opt_o) { + open $out, '>', $opt_o or die "Can't create $opt_o: $!\n"; +} else { + $out = STDOUT; +} + +&OutputDBD($out, $dbd); + +if ($opt_o) { + close $out or die "Closing $opt_o failed: $!\n"; +} +exit 0; diff --git a/src/dbHost/dbdReport b/src/dbHost/dbdReport index 7b0060c98..a9d198614 100755 --- a/src/dbHost/dbdReport +++ b/src/dbHost/dbdReport @@ -1,8 +1,11 @@ #!/usr/bin/perl +use FindBin qw($Bin); +use lib "$Bin/../../lib/perl"; + use DBD; use DBD::Parser; -use Getopts; +use EPICS::Getopts; use macLib; use Readfile; use Text::Wrap; From f6527a99427638a8c6e47c23ebad51841207cd7f Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 17:29:17 -0500 Subject: [PATCH 15/32] 2009-02-15: Fix problem parsing function() statements. --- src/dbHost/DBD/Parser.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/dbHost/DBD/Parser.pm b/src/dbHost/DBD/Parser.pm index 376d66626..11af4df76 100644 --- a/src/dbHost/DBD/Parser.pm +++ b/src/dbHost/DBD/Parser.pm @@ -43,7 +43,7 @@ sub ParseDBD { } elsif (m/\G function \s* \( \s* $string \s* \)/oxgc) { print "Function: $1\n" if $debug; - $dbd->add(DBD::Function($1)); + $dbd->add(DBD::Function->new($1)); } elsif (m/\G breaktable \s* \( \s* $string \s* \) \s* \{/oxgc) { print "Breaktable: $1\n" if $debug; From f00684c8c392538982af283b9bf98b1a8258140b Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 8 Apr 2010 17:30:15 -0500 Subject: [PATCH 16/32] 2009-12-22: Suggestion... --- src/dbHost/Readfile.pm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/dbHost/Readfile.pm b/src/dbHost/Readfile.pm index 371f3c666..1a04a7e0a 100644 --- a/src/dbHost/Readfile.pm +++ b/src/dbHost/Readfile.pm @@ -28,6 +28,8 @@ sub slurp { open FILE, "<$FILE" or die "Can't open $FILE: $!\n"; push @inputfiles, $FILE; my @lines = ("##!BEGIN{$FILE}!##\n"); + # Consider replacing these markers with C pre-processor linemarkers. + # See 'info cpp' * Preprocessor Output:: for details. push @lines, ; push @lines, "##!END{$FILE}!##\n"; close FILE or die "Error closing $FILE: $!\n"; From ce43b9faf86d84ed2c406c1ae7c3de871da35ef3 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Tue, 13 Apr 2010 17:05:59 -0500 Subject: [PATCH 17/32] Reorganized files, configure to use new versions. * Moved Readfile and macLib into tools/EPICS * dbHost/Getopts was a duplicate * Added (c) headers * Build in the dbHost dir * Switch build system to use Perl versions. --- configure/CONFIG_BASE | 8 +-- src/Makefile | 3 + src/dbHost/Getopts.pm | 76 ------------------------- src/dbHost/Makefile | 2 - src/dbHost/dbdExpand.pl | 13 ++++- src/dbHost/dbdReport | 15 ++++- src/dbHost/dbdToMenuH.pl | 10 +++- src/dbHost/dbdToRecordtypeH.pl | 10 +++- src/{dbHost => tools/EPICS}/Readfile.pm | 13 ++++- src/{dbHost => tools/EPICS}/macLib.pm | 17 ++++-- src/tools/Makefile | 2 + 11 files changed, 74 insertions(+), 95 deletions(-) delete mode 100644 src/dbHost/Getopts.pm rename src/{dbHost => tools/EPICS}/Readfile.pm (85%) rename src/{dbHost => tools/EPICS}/macLib.pm (92%) diff --git a/configure/CONFIG_BASE b/configure/CONFIG_BASE index e88e1e80d..5b5319b2c 100644 --- a/configure/CONFIG_BASE +++ b/configure/CONFIG_BASE @@ -57,11 +57,11 @@ TOOLS = $(EPICS_BASE_HOST_BIN) # Epics base build tools and tool flags MAKEBPT = $(call PATH_FILTER, $(TOOLS)/makeBpt$(HOSTEXE)) -DBEXPAND = $(call PATH_FILTER, $(TOOLS)/dbExpand$(HOSTEXE)) -DBTORECORDTYPEH = $(call PATH_FILTER, $(TOOLS)/dbToRecordtypeH$(HOSTEXE)) -DBTOMENUH = $(call PATH_FILTER, $(TOOLS)/dbToMenuH$(HOSTEXE)) +DBEXPAND = $(PERL) $(TOOLS)/dbdExpand.pl +DBTORECORDTYPEH = $(PERL) $(TOOLS)/dbdToRecordtypeH.pl +DBTOMENUH = $(PERL) $(TOOLS)/dbdToMenuH.pl REGISTERRECORDDEVICEDRIVER = $(PERL) $(TOOLS)/registerRecordDeviceDriver.pl -CONVERTRELEASE=$(PERL) $(TOOLS)/convertRelease.pl +CONVERTRELEASE = $(PERL) $(TOOLS)/convertRelease.pl #------------------------------------------------------- # tools for installing libraries and products diff --git a/src/Makefile b/src/Makefile index 88a03d7c6..b370c1d50 100644 --- a/src/Makefile +++ b/src/Makefile @@ -23,6 +23,9 @@ template/ext_DEPEND_DIRS = tools # Common +DIRS += dbHost +dbHost_DEPEND_DIRS = tools + DIRS += libCom libCom_DEPEND_DIRS = tools diff --git a/src/dbHost/Getopts.pm b/src/dbHost/Getopts.pm deleted file mode 100644 index 53b08e447..000000000 --- a/src/dbHost/Getopts.pm +++ /dev/null @@ -1,76 +0,0 @@ -package Getopts; -require 5.000; -require Exporter; - -@ISA = qw(Exporter); -@EXPORT = qw(getopts); - -# getopts.pl - our getopts stuff -# -# This version of getopts is modified from the Perl original in the -# following ways: -# -# 1. The perl routine in GetOpt::Std allows a perl hash to be passed -# in as a third argument and used for storing option values. This -# functionality has been deleted. -# 2. Arguments without a ':' modifier are now counted, rather than -# being binary. This means that multiple copies of the same option -# can be detected by the program. -# 3. A new '@' modifier is provided which collects the option arguments -# in an array @opt_X. Multiple copies of this option are permitted -# and push the arguments onto the end of the list. - -sub getopts ( $;$ ) { - my ($argumentative) = @_; - my (@args,$first,$rest); - my $errs = 0; - local $_; - local @EXPORT; - - @args = split( / */, $argumentative ); - while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { - ($first,$rest) = ($1,$2); - if (/^--$/) { # early exit if -- - shift @ARGV; - last; - } - $pos = index($argumentative,$first); - if ($pos >= 0) { - if (defined($args[$pos+1]) and (index(':@', $args[$pos+1]) >= 0)) { - shift(@ARGV); - if ($rest eq '') { - ++$errs unless @ARGV; - $rest = shift(@ARGV); - } - if ($args[$pos+1] eq ':') { - ${"opt_$first"} = $rest; - push @EXPORT, "\$opt_$first"; - } elsif ($args[$pos+1] eq '@') { - push @{"opt_$first"}, $rest; - push @EXPORT, "\@opt_$first"; - } - } else { - ${"opt_$first"} += 1; - push @EXPORT, "\$opt_$first"; - if ($rest eq '') { - shift(@ARGV); - } else { - $ARGV[0] = "-$rest"; - } - } - } else { - warn "Unknown option: $first\n"; - ++$errs; - if ($rest ne '') { - $ARGV[0] = "-$rest"; - } else { - shift(@ARGV); - } - } - } - local $Exporter::ExportLevel = 1; - import Getopts; - $errs == 0; -} - -1; diff --git a/src/dbHost/Makefile b/src/dbHost/Makefile index 0158ca2a5..927d8f53c 100644 --- a/src/dbHost/Makefile +++ b/src/dbHost/Makefile @@ -7,8 +7,6 @@ TOP=../.. include $(TOP)/configure/CONFIG -PERL_MODULES += macLib.pm -PERL_MODULES += Readfile.pm PERL_MODULES += DBD.pm PERL_MODULES += DBD/Base.pm PERL_MODULES += DBD/Breaktable.pm diff --git a/src/dbHost/dbdExpand.pl b/src/dbHost/dbdExpand.pl index 5919ddbe4..34df25f4e 100755 --- a/src/dbHost/dbdExpand.pl +++ b/src/dbHost/dbdExpand.pl @@ -1,5 +1,14 @@ #!/usr/bin/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 FindBin qw($Bin); use lib "$Bin/../../lib/perl"; @@ -8,13 +17,13 @@ use DBD::Parser; use DBD::Output; use EPICS::Getopts; use Readfile; -use macLib; +use EPICS::macLib; getopts('DI@S@o:') or die "Usage: dbdExpand [-D] [-I dir] [-S macro=val] [-o out.dbd] in.dbd ..."; my @path = map { split /[:;]/ } @opt_I; -my $macros = macLib->new(@opt_S); +my $macros = EPICS::macLib->new(@opt_S); my $dbd = DBD->new(); while (@ARGV) { diff --git a/src/dbHost/dbdReport b/src/dbHost/dbdReport index a9d198614..b62e84ded 100755 --- a/src/dbHost/dbdReport +++ b/src/dbHost/dbdReport @@ -1,16 +1,25 @@ #!/usr/bin/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 FindBin qw($Bin); use lib "$Bin/../../lib/perl"; use DBD; use DBD::Parser; use EPICS::Getopts; -use macLib; +use EPICS::macLib; use Readfile; use Text::Wrap; -#$Readfile::debug = 1; +#$EPICS::Readfile::debug = 1; #$DBD::Parser::debug = 1; getopts('I@S@') or die usage(); @@ -20,7 +29,7 @@ sub usage() { } my @path = map { split /[:;]/ } @opt_I; -my $macros = macLib->new(@opt_S); +my $macros = EPICS::macLib->new(@opt_S); my $dbd = DBD->new(); &ParseDBD($dbd, &Readfile(shift @ARGV, $macros, \@opt_I)); diff --git a/src/dbHost/dbdToMenuH.pl b/src/dbHost/dbdToMenuH.pl index e321bc336..3f52fa446 100755 --- a/src/dbHost/dbdToMenuH.pl +++ b/src/dbHost/dbdToMenuH.pl @@ -1,4 +1,12 @@ #!/usr/bin/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 FindBin qw($Bin); @@ -8,7 +16,7 @@ use EPICS::Getopts; use File::Basename; use DBD; use DBD::Parser; -use macLib; +use EPICS::macLib; use Readfile; my $tool = 'dbdToMenuH.pl'; diff --git a/src/dbHost/dbdToRecordtypeH.pl b/src/dbHost/dbdToRecordtypeH.pl index 0850b6e2a..6c0f0c575 100755 --- a/src/dbHost/dbdToRecordtypeH.pl +++ b/src/dbHost/dbdToRecordtypeH.pl @@ -1,4 +1,12 @@ #!/usr/bin/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 FindBin qw($Bin); @@ -8,7 +16,7 @@ use EPICS::Getopts; use File::Basename; use DBD; use DBD::Parser; -use macLib; +use EPICS::macLib; use Readfile; my $tool = 'dbdToRecordtypeH.pl'; diff --git a/src/dbHost/Readfile.pm b/src/tools/EPICS/Readfile.pm similarity index 85% rename from src/dbHost/Readfile.pm rename to src/tools/EPICS/Readfile.pm index 1a04a7e0a..43ee493f4 100644 --- a/src/dbHost/Readfile.pm +++ b/src/tools/EPICS/Readfile.pm @@ -1,8 +1,17 @@ -package Readfile; +#************************************************************************* +# 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$ + +package EPICS::Readfile; require 5.000; require Exporter; -use macLib; +use EPICS::macLib; @ISA = qw(Exporter); @EXPORT = qw(@inputfiles &Readfile); diff --git a/src/dbHost/macLib.pm b/src/tools/EPICS/macLib.pm similarity index 92% rename from src/dbHost/macLib.pm rename to src/tools/EPICS/macLib.pm index e4065483c..332ceca67 100644 --- a/src/dbHost/macLib.pm +++ b/src/tools/EPICS/macLib.pm @@ -1,4 +1,13 @@ -package macLib::entry; +#************************************************************************* +# 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$ + +package EPICS::macLib::entry; sub new ($$) { my $class = shift; @@ -22,7 +31,7 @@ sub report ($) { } -package macLib; +package EPICS::macLib; use Carp; @@ -88,7 +97,7 @@ sub putValue ($$$) { $this->{macros}[0]{$name}{raw} = $raw; } } else { - my $entry = macLib::entry->new($name, 'macro'); + my $entry = EPICS::macLib::entry->new($name, 'macro'); $entry->{raw} = $raw; $this->{macros}[0]{$name} = $entry; } @@ -113,7 +122,7 @@ sub suppressWarning($$) { sub expandString($$) { my ($this, $src) = @_; $this->_expand; - my $entry = macLib::entry->new($src, 'string'); + my $entry = EPICS::macLib::entry->new($src, '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 4dfc7aa1d..73a70cf88 100644 --- a/src/tools/Makefile +++ b/src/tools/Makefile @@ -14,7 +14,9 @@ TOOLS = $(TOP)/src/tools PERL_MODULES += EPICS/Copy.pm PERL_MODULES += EPICS/Path.pm PERL_MODULES += EPICS/Release.pm +PERL_MODULES += EPICS/Readfile.pm PERL_MODULES += EPICS/Getopts.pm +PERL_MODULES += EPICS/macLib.pm PERL_SCRIPTS += convertRelease.pl PERL_SCRIPTS += cvsclean.pl From afc57e42f9aab17d432b939eca5000736a53f35c Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Tue, 13 Apr 2010 17:36:06 -0500 Subject: [PATCH 18/32] Note questionable handling of -I option on Win32. --- src/dbHost/dbdExpand.pl | 2 +- src/dbHost/dbdReport | 2 +- src/dbHost/dbdToMenuH.pl | 2 +- src/dbHost/dbdToRecordtypeH.pl | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/dbHost/dbdExpand.pl b/src/dbHost/dbdExpand.pl index 34df25f4e..36ff01999 100755 --- a/src/dbHost/dbdExpand.pl +++ b/src/dbHost/dbdExpand.pl @@ -22,7 +22,7 @@ use EPICS::macLib; getopts('DI@S@o:') or die "Usage: dbdExpand [-D] [-I dir] [-S macro=val] [-o out.dbd] in.dbd ..."; -my @path = map { split /[:;]/ } @opt_I; +my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32? my $macros = EPICS::macLib->new(@opt_S); my $dbd = DBD->new(); diff --git a/src/dbHost/dbdReport b/src/dbHost/dbdReport index b62e84ded..bd6cd5a32 100755 --- a/src/dbHost/dbdReport +++ b/src/dbHost/dbdReport @@ -28,7 +28,7 @@ sub usage() { "Usage: dbdReport [-I dir:dir2] [-S macro=val,...] file.dbd ..."; } -my @path = map { split /[:;]/ } @opt_I; +my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32? my $macros = EPICS::macLib->new(@opt_S); my $dbd = DBD->new(); diff --git a/src/dbHost/dbdToMenuH.pl b/src/dbHost/dbdToMenuH.pl index 3f52fa446..1d19799d1 100755 --- a/src/dbHost/dbdToMenuH.pl +++ b/src/dbHost/dbdToMenuH.pl @@ -25,7 +25,7 @@ use vars qw($opt_D @opt_I $opt_o $opt_s); getopts('DI@o:') or die "Usage: $tool: [-D] [-I dir] [-o menu.h] menu.dbd [menu.h]\n"; -my @path = map { split /[:;]/ } @opt_I; +my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32? my $dbd = DBD->new(); my $infile = shift @ARGV; diff --git a/src/dbHost/dbdToRecordtypeH.pl b/src/dbHost/dbdToRecordtypeH.pl index 6c0f0c575..be513e5c2 100755 --- a/src/dbHost/dbdToRecordtypeH.pl +++ b/src/dbHost/dbdToRecordtypeH.pl @@ -25,7 +25,7 @@ use vars qw($opt_D @opt_I $opt_o $opt_s); getopts('DI@o:s') or die "Usage: $tool [-D] [-I dir] [-o xRecord.h] xRecord.dbd [xRecord.h]\n"; -my @path = map { split /[:;]/ } @opt_I; +my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32? my $dbd = DBD->new(); my $infile = shift @ARGV; From 5e85476352682170a3076f7b060379f30bb86935 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Tue, 13 Apr 2010 17:39:27 -0500 Subject: [PATCH 19/32] Remove programs that were replaced in Perl. --- src/dbHost/dbdExpand.pl | 2 +- src/dbHost/dbdToMenuH.pl | 2 +- src/dbHost/dbdToRecordtypeH.pl | 2 +- src/ioc/dbStatic/Makefile | 18 +- src/ioc/dbStatic/dbExpand.c | 123 ------------- src/ioc/dbStatic/dbReadTest.c | 90 ---------- src/ioc/dbStatic/dbToMenuH.c | 124 -------------- src/ioc/dbStatic/dbToRecordtypeH.c | 267 ----------------------------- 8 files changed, 4 insertions(+), 624 deletions(-) delete mode 100644 src/ioc/dbStatic/dbExpand.c delete mode 100644 src/ioc/dbStatic/dbReadTest.c delete mode 100644 src/ioc/dbStatic/dbToMenuH.c delete mode 100644 src/ioc/dbStatic/dbToRecordtypeH.c diff --git a/src/dbHost/dbdExpand.pl b/src/dbHost/dbdExpand.pl index 36ff01999..2335cbddd 100755 --- a/src/dbHost/dbdExpand.pl +++ b/src/dbHost/dbdExpand.pl @@ -16,7 +16,7 @@ use DBD; use DBD::Parser; use DBD::Output; use EPICS::Getopts; -use Readfile; +use EPICS::Readfile; use EPICS::macLib; getopts('DI@S@o:') or diff --git a/src/dbHost/dbdToMenuH.pl b/src/dbHost/dbdToMenuH.pl index 1d19799d1..1e5f35fb2 100755 --- a/src/dbHost/dbdToMenuH.pl +++ b/src/dbHost/dbdToMenuH.pl @@ -17,7 +17,7 @@ use File::Basename; use DBD; use DBD::Parser; use EPICS::macLib; -use Readfile; +use EPICS::Readfile; my $tool = 'dbdToMenuH.pl'; diff --git a/src/dbHost/dbdToRecordtypeH.pl b/src/dbHost/dbdToRecordtypeH.pl index be513e5c2..763f51b44 100755 --- a/src/dbHost/dbdToRecordtypeH.pl +++ b/src/dbHost/dbdToRecordtypeH.pl @@ -17,7 +17,7 @@ use File::Basename; use DBD; use DBD::Parser; use EPICS::macLib; -use Readfile; +use EPICS::Readfile; my $tool = 'dbdToRecordtypeH.pl'; diff --git a/src/ioc/dbStatic/Makefile b/src/ioc/dbStatic/Makefile index 6b2d16840..c2f642bb1 100644 --- a/src/ioc/dbStatic/Makefile +++ b/src/ioc/dbStatic/Makefile @@ -32,26 +32,10 @@ dbCore_SRCS += dbStaticRun.c dbCore_SRCS += dbStaticIocRegister.c dbStaticHost_SRCS += $(STATIC_SRCS) -dbStaticHost_SRCS += dbStaticNoRun.c +dbStaticHost_SRCS += dbStaticNoRun.c LIBRARY_HOST += dbStaticHost dbStaticHost_LIBS = Com -PROD_HOST += dbReadTest dbExpand dbToMenuH dbToRecordtypeH - -dbReadTest_SRCS = dbReadTest.c -dbExpand_SRCS = dbExpand.c -dbToMenuH_SRCS = dbToMenuH.c -dbToRecordtypeH_SRCS = dbToRecordtypeH.c - -# Include dbStaticHost objects directly in executables -# because of a Circular dependency induced by a rule -# $(INSTALL_LIBS): $(INSTALL_SHRLIBS) -# in RULES_BUILD -dbReadTest_SRCS += $(dbStaticHost_SRCS) -dbExpand_SRCS += $(dbStaticHost_SRCS) -dbToMenuH_SRCS += $(dbStaticHost_SRCS) -dbToRecordtypeH_SRCS += $(dbStaticHost_SRCS) - CLEANS += dbLex.c dbYacc.c diff --git a/src/ioc/dbStatic/dbExpand.c b/src/ioc/dbStatic/dbExpand.c deleted file mode 100644 index 80c95cabd..000000000 --- a/src/ioc/dbStatic/dbExpand.c +++ /dev/null @@ -1,123 +0,0 @@ -/*************************************************************************\ -* Copyright (c) 2002 The University of Chicago, as Operator of Argonne -* National Laboratory. -* Copyright (c) 2002 The Regents of the University of California, as -* Operator of Los Alamos National Laboratory. -* EPICS BASE Versions 3.13.7 -* and higher are distributed subject to a Software License Agreement found -* in file LICENSE that is included with this distribution. -\*************************************************************************/ -/* dbExpand.c */ -/* Author: Marty Kraimer Date: 30NOV95 */ - -#include -#include -#include -#include - -#include "dbDefs.h" -#include "epicsPrint.h" -#include "errMdef.h" -#include "dbStaticLib.h" -#include "dbStaticPvt.h" -#include "dbBase.h" -#include "gpHash.h" -#include "osiFileName.h" - -DBBASE *pdbbase = NULL; - -void usage(void) -{ - fprintf(stderr, "Usage:\n\tdbExpand -Ipath -ooutfile " - "-S macro=value file1.dbd file2.dbd ...\n"); - fprintf(stderr,"Specifying any path will replace the default of '.'\n"); -} - -int main(int argc,char **argv) -{ - char *path = NULL; - char *sub = NULL; - int pathLength = 0; - int subLength = 0; - char *outFilename = NULL; - FILE *outFP = stdout; - long status; - long returnStatus = 0; - static char *pathSep = OSI_PATH_LIST_SEPARATOR; - static char *subSep = ","; - - /* Discard program name argv[0] */ - ++argv; - --argc; - - while ((argc > 1) && (**argv == '-')) { - char optLtr = (*argv)[1]; - char *optArg; - - if (strlen(*argv) > 2) { - optArg = *argv+2; - ++argv; - --argc; - } else { - optArg = argv[1]; - argv += 2; - argc -= 2; - } - - switch (optLtr) { - case 'o': - outFilename = optArg; - break; - - case 'I': - dbCatString(&path, &pathLength, optArg, pathSep); - break; - - case 'S': - dbCatString(&sub, &subLength, optArg, subSep); - break; - - default: - fprintf(stderr, "dbExpand: Unknown option '-%c'\n", optLtr); - usage(); - exit(1); - } - } - - if (argc < 1) { - fprintf(stderr, "dbExpand: No input file specified\n"); - usage(); - exit(1); - } - - for (; argc>0; --argc, ++argv) { - status = dbReadDatabase(&pdbbase,*argv,path,sub); - if (status) returnStatus = status; - } - if (returnStatus) { - errlogFlush(); - fprintf(stderr, "dbExpand: Input errors, no output generated\n"); - exit(1); - } - if (outFilename) { - outFP = fopen(outFilename, "w"); - if (!outFP) { - perror("dbExpand"); - exit(1); - } - } - - dbWriteMenuFP(pdbbase,outFP,0); - dbWriteRecordTypeFP(pdbbase,outFP,0); - dbWriteDeviceFP(pdbbase,outFP); - dbWriteDriverFP(pdbbase,outFP); - dbWriteRegistrarFP(pdbbase,outFP); - dbWriteFunctionFP(pdbbase,outFP); - dbWriteVariableFP(pdbbase,outFP); - dbWriteBreaktableFP(pdbbase,outFP); - dbWriteRecordFP(pdbbase,outFP,0,0); - - free((void *)path); - free((void *)sub); - return 0; -} diff --git a/src/ioc/dbStatic/dbReadTest.c b/src/ioc/dbStatic/dbReadTest.c deleted file mode 100644 index c7a433232..000000000 --- a/src/ioc/dbStatic/dbReadTest.c +++ /dev/null @@ -1,90 +0,0 @@ -/*************************************************************************\ -* Copyright (c) 2002 The University of Chicago, as Operator of Argonne -* National Laboratory. -* Copyright (c) 2002 The Regents of the University of California, as -* Operator of Los Alamos National Laboratory. -* EPICS BASE Versions 3.13.7 -* and higher are distributed subject to a Software License Agreement found -* in file LICENSE that is included with this distribution. -\*************************************************************************/ -/* dbReadTest.c */ -/* Author: Marty Kraimer Date: 13JUL95 */ - -#include -#include -#include -#include - -#include "dbDefs.h" -#include "epicsPrint.h" -#include "errMdef.h" -#include "dbStaticLib.h" -#include "dbStaticPvt.h" -#include "dbBase.h" -#include "gpHash.h" -#include "osiFileName.h" - -DBBASE *pdbbase = NULL; - -int main(int argc,char **argv) -{ - int i; - int strip; - char *path = NULL; - char *sub = NULL; - int pathLength = 0; - int subLength = 0; - char **pstr; - char *psep; - int *len; - long status; - static char *pathSep = OSI_PATH_LIST_SEPARATOR; - static char *subSep = ","; - - /*Look for options*/ - if(argc<2) { - printf("usage: dbReadTest -Idir -Smacsub file.dbd file.db \n"); - exit(0); - } - while((strncmp(argv[1],"-I",2)==0)||(strncmp(argv[1],"-S",2)==0)) { - if(strncmp(argv[1],"-I",2)==0) { - pstr = &path; - psep = pathSep; - len = &pathLength; - } else { - pstr = ⊂ - psep = subSep; - len = &subLength; - } - if(strlen(argv[1])==2) { - dbCatString(pstr,len,argv[2],psep); - strip = 2; - } else { - dbCatString(pstr,len,argv[1]+2,psep); - strip = 1; - } - argc -= strip; - for(i=1; ipgpHash); - dbDumpMenu(pdbbase,NULL); - dbDumpRecord(pdbbase,NULL,0); - dbReportDeviceConfig(pdbbase,stdout); -*/ - dbFreeBase(pdbbase); - return(0); -} diff --git a/src/ioc/dbStatic/dbToMenuH.c b/src/ioc/dbStatic/dbToMenuH.c deleted file mode 100644 index e910d1a78..000000000 --- a/src/ioc/dbStatic/dbToMenuH.c +++ /dev/null @@ -1,124 +0,0 @@ -/*************************************************************************\ -* Copyright (c) 2002 The University of Chicago, as Operator of Argonne -* National Laboratory. -* Copyright (c) 2002 The Regents of the University of California, as -* Operator of Los Alamos National Laboratory. -* EPICS BASE Versions 3.13.7 -* and higher are distributed subject to a Software License Agreement found -* in file LICENSE that is included with this distribution. -\*************************************************************************/ -/* dbToMenu.c */ -/* Author: Marty Kraimer Date: 11Sep95 */ -#include -#include -#include -#include - -#include "dbDefs.h" -#include "epicsPrint.h" -#include "errMdef.h" -#include "dbStaticLib.h" -#include "dbStaticPvt.h" -#include "dbBase.h" -#include "gpHash.h" -#include "osiFileName.h" - -DBBASE *pdbbase = NULL; - -int main(int argc,char **argv) -{ - dbMenu *pdbMenu; - char *outFilename; - char *pext; - FILE *outFile; - char *plastSlash; - int i; - int strip; - char *path = NULL; - char *sub = NULL; - int pathLength = 0; - int subLength = 0; - char **pstr; - char *psep; - int *len; - long status; - static char *pathSep = OSI_PATH_LIST_SEPARATOR; - static char *subSep = ","; - - /*Look for options*/ - if(argc<2) { - fprintf(stderr,"usage: dbToMenu -Idir -Idir file.dbd [outfile]\n"); - exit(0); - } - while((strncmp(argv[1],"-I",2)==0)||(strncmp(argv[1],"-S",2)==0)) { - if(strncmp(argv[1],"-I",2)==0) { - pstr = &path; - psep = pathSep; - len = &pathLength; - } else { - pstr = ⊂ - psep = subSep; - len = &subLength; - } - if(strlen(argv[1])==2) { - dbCatString(pstr,len,argv[2],psep); - strip = 2; - } else { - dbCatString(pstr,len,argv[1]+2,psep); - strip = 1; - } - argc -= strip; - for(i=1; iignoreMissingMenus = TRUE; - status = dbReadDatabase(&pdbbase,argv[1],path,sub); - if (status) { - errlogFlush(); - fprintf(stderr, "dbToMenuH: Input errors, no output generated\n"); - exit(1); - } - outFile = fopen(outFilename, "w"); - if (!outFile) { - epicsPrintf("Error creating output file \"%s\"\n", outFilename); - exit(1); - } - pdbMenu = (dbMenu *)ellFirst(&pdbbase->menuList); - while(pdbMenu) { - fprintf(outFile,"#ifndef INC%sH\n",pdbMenu->name); - fprintf(outFile,"#define INC%sH\n",pdbMenu->name); - fprintf(outFile,"typedef enum {\n"); - for(i=0; inChoice; i++) { - fprintf(outFile,"\t%s",pdbMenu->papChoiceName[i]); - if(i < (pdbMenu->nChoice - 1)) fprintf(outFile,","); - fprintf(outFile,"\n"); - } - fprintf(outFile,"}%s;\n",pdbMenu->name); - fprintf(outFile,"#endif /*INC%sH*/\n",pdbMenu->name); - pdbMenu = (dbMenu *)ellNext(&pdbMenu->node); - } - fclose(outFile); - free((void *)outFilename); - return(0); -} diff --git a/src/ioc/dbStatic/dbToRecordtypeH.c b/src/ioc/dbStatic/dbToRecordtypeH.c deleted file mode 100644 index a97a44f87..000000000 --- a/src/ioc/dbStatic/dbToRecordtypeH.c +++ /dev/null @@ -1,267 +0,0 @@ -/*************************************************************************\ -* Copyright (c) 2007 UChicago Argonne LLC, as Operator of Argonne -* National Laboratory. -* Copyright (c) 2002 The Regents of the University of California, as -* Operator of Los Alamos National Laboratory. -* EPICS BASE is distributed subject to a Software License Agreement found -* in file LICENSE that is included with this distribution. -\*************************************************************************/ -/* dbToRecordtypeH.c */ -/* Author: Marty Kraimer Date: 11Sep95 */ - -#include -#include -#include -#include -#include - -#include "dbDefs.h" -#include "epicsPrint.h" -#include "errMdef.h" -#include "dbStaticLib.h" -#include "dbStaticPvt.h" -#include "dbBase.h" -#include "gpHash.h" -#include "osiFileName.h" - -DBBASE *pdbbase = NULL; - -int main(int argc,char **argv) -{ - int i; - char *outFilename; - char *pext; - FILE *outFile; - dbMenu *pdbMenu; - dbRecordType *pdbRecordType; - dbFldDes *pdbFldDes; - dbText *pdbCdef; - int isdbCommonRecord = FALSE; - char *plastSlash; - int strip; - char *path = NULL; - char *sub = NULL; - int pathLength = 0; - int subLength = 0; - char **pstr; - char *psep; - int *len; - long status; - static char *pathSep = OSI_PATH_LIST_SEPARATOR; - static char *subSep = ","; - - /*Look for options*/ - if(argc<2) { - fprintf(stderr,"usage: dbToRecordtypeH -Idir -Idir file.dbd [outfile]\n"); - exit(0); - } - while((strncmp(argv[1],"-I",2)==0)||(strncmp(argv[1],"-S",2)==0)) { - if(strncmp(argv[1],"-I",2)==0) { - pstr = &path; - psep = pathSep; - len = &pathLength; - } else { - pstr = ⊂ - psep = subSep; - len = &subLength; - } - if(strlen(argv[1])==2) { - dbCatString(pstr,len,argv[2],psep); - strip = 2; - } else { - dbCatString(pstr,len,argv[1]+2,psep); - strip = 1; - } - argc -= strip; - for(i=1; iignoreMissingMenus = TRUE; - pdbbase->loadCdefs = TRUE; - status = dbReadDatabase(&pdbbase,argv[1],path,sub); - if(status) { - errlogFlush(); - fprintf(stderr, "dbToMenuH: Input errors, no output generated\n"); - exit(1); - } - outFile = fopen(outFilename,"w"); - if(!outFile) { - epicsPrintf("Error creating output file \"%s\"\n", outFilename); - exit(1); - } - - pdbMenu = (dbMenu *)ellFirst(&pdbbase->menuList); - while(pdbMenu) { - fprintf(outFile,"\n#ifndef INC%sH\n",pdbMenu->name); - fprintf(outFile,"#define INC%sH\n",pdbMenu->name); - fprintf(outFile,"typedef enum {\n"); - for(i=0; inChoice; i++) { - fprintf(outFile,"\t%s",pdbMenu->papChoiceName[i]); - if(i < (pdbMenu->nChoice - 1)) fprintf(outFile,","); - fprintf(outFile,"\n"); - } - fprintf(outFile,"}%s;\n",pdbMenu->name); - fprintf(outFile,"#endif /*INC%sH*/\n",pdbMenu->name); - pdbMenu = (dbMenu *)ellNext(&pdbMenu->node); - } - pdbRecordType = (dbRecordType *)ellFirst(&pdbbase->recordTypeList); - while(pdbRecordType) { - fprintf(outFile,"#ifndef INC%sH\n",pdbRecordType->name); - fprintf(outFile,"#define INC%sH\n",pdbRecordType->name); - pdbCdef = (dbText *)ellFirst(&pdbRecordType->cdefList); - while (pdbCdef) { - fprintf(outFile,"%s\n",pdbCdef->text); - pdbCdef = (dbText *)ellNext(&pdbCdef->node); - } - fprintf(outFile,"typedef struct %s",pdbRecordType->name); - if(!isdbCommonRecord) fprintf(outFile,"Record"); - fprintf(outFile," {\n"); - for(i=0; ino_fields; i++) { - char name[256]; - int j; - - pdbFldDes = pdbRecordType->papFldDes[i]; - for(j=0; j< (int)strlen(pdbFldDes->name); j++) - name[j] = tolower(pdbFldDes->name[j]); - name[strlen(pdbFldDes->name)] = 0; - switch(pdbFldDes->field_type) { - case DBF_STRING : - fprintf(outFile, "\tchar\t\t%s[%d];\t/* %s */\n", - name, pdbFldDes->size, pdbFldDes->prompt); - break; - case DBF_CHAR : - fprintf(outFile, "\tepicsInt8\t%s;\t/* %s */\n", - name, pdbFldDes->prompt); - break; - case DBF_UCHAR : - fprintf(outFile, "\tepicsUInt8\t%s;\t/* %s */\n", - name, pdbFldDes->prompt); - break; - case DBF_SHORT : - fprintf(outFile, "\tepicsInt16\t%s;\t/* %s */\n", - name, pdbFldDes->prompt); - break; - case DBF_USHORT : - fprintf(outFile, "\tepicsUInt16\t%s;\t/* %s */\n", - name, pdbFldDes->prompt); - break; - case DBF_LONG : - fprintf(outFile, "\tepicsInt32\t%s;\t/* %s */\n", - name, pdbFldDes->prompt); - break; - case DBF_ULONG : - fprintf(outFile, "\tepicsUInt32\t%s;\t/* %s */\n", - name, pdbFldDes->prompt); - break; - case DBF_FLOAT : - fprintf(outFile, "\tepicsFloat32\t%s;\t/* %s */\n", - name, pdbFldDes->prompt); - break; - case DBF_DOUBLE : - fprintf(outFile, "\tepicsFloat64\t%s;\t/* %s */\n", - name, pdbFldDes->prompt); - break; - case DBF_ENUM : - case DBF_MENU : - case DBF_DEVICE : - fprintf(outFile, "\tepicsEnum16\t%s;\t/* %s */\n", - name, pdbFldDes->prompt); - break; - case DBF_INLINK : - case DBF_OUTLINK : - case DBF_FWDLINK : - fprintf(outFile, "\tDBLINK\t\t%s;\t/* %s */\n", - name, pdbFldDes->prompt); - break; - case DBF_NOACCESS: - fprintf(outFile, "\t%s;\t/* %s */\n", - pdbFldDes->extra, pdbFldDes->prompt); - break; - default: - fprintf(outFile,"ILLEGAL FIELD TYPE\n"); - } - } - fprintf(outFile,"} %s",pdbRecordType->name); - if(!isdbCommonRecord) fprintf(outFile,"Record"); - fprintf(outFile,";\n"); - if(!isdbCommonRecord) { - for(i=0; ino_fields; i++) { - pdbFldDes = pdbRecordType->papFldDes[i]; - fprintf(outFile,"#define %sRecord%s\t%d\n", - pdbRecordType->name,pdbFldDes->name,pdbFldDes->indRecordType); - } - } - fprintf(outFile,"#endif /*INC%sH*/\n",pdbRecordType->name); - pdbRecordType = (dbRecordType *)ellNext(&pdbRecordType->node); - if(pdbRecordType) fprintf(outFile,"\n"); - } - if(!isdbCommonRecord) { - fprintf(outFile,"#ifdef GEN_SIZE_OFFSET\n"); - fprintf(outFile,"#ifdef __cplusplus\n"); - fprintf(outFile,"extern \"C\" {\n"); - fprintf(outFile,"#endif\n"); - fprintf(outFile,"#include \n"); - pdbRecordType = (dbRecordType *)ellFirst(&pdbbase->recordTypeList); - while(pdbRecordType) { - fprintf(outFile,"static int %sRecordSizeOffset(dbRecordType *pdbRecordType)\n{\n", - pdbRecordType->name); - fprintf(outFile," %sRecord *prec = 0;\n",pdbRecordType->name); - for(i=0; ino_fields; i++) { - char name[256]; - int j; - - pdbFldDes = pdbRecordType->papFldDes[i]; - for(j=0; j< (int)strlen(pdbFldDes->name); j++) - name[j] = tolower(pdbFldDes->name[j]); - name[strlen(pdbFldDes->name)] = 0; - fprintf(outFile, - " pdbRecordType->papFldDes[%d]->size=sizeof(prec->%s);\n", - i,name); - fprintf(outFile," pdbRecordType->papFldDes[%d]->offset=",i); - fprintf(outFile, - "(short)((char *)&prec->%s - (char *)prec);\n",name); - } - fprintf(outFile," pdbRecordType->rec_size = sizeof(*prec);\n"); - fprintf(outFile," return(0);\n"); - fprintf(outFile,"}\n"); - fprintf(outFile,"epicsExportRegistrar(%sRecordSizeOffset);\n", - pdbRecordType->name); - pdbRecordType = (dbRecordType *)ellNext(&pdbRecordType->node); - } - fprintf(outFile,"#ifdef __cplusplus\n"); - fprintf(outFile,"}\n"); - fprintf(outFile,"#endif\n"); - fprintf(outFile,"#endif /*GEN_SIZE_OFFSET*/\n"); - } - fclose(outFile); - free((void *)outFilename); - return(0); -} From 510027aa2cbe8d348af97a193bdd631bd3efab3b Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Wed, 14 Apr 2010 15:16:36 -0500 Subject: [PATCH 20/32] Reject field names that are reserved words. The list of reserved words is combined from C++ and the DB/DBD file parser. This also requires a small change in the rules for generating the C name from the DBD field name, since the aSub record has a field NOT; now if we find the lower-case version is reserved, we use the original instead. Since the aSubRecord.c file doesn't use prec->not this is back-compatible. --- src/dbHost/DBD/Base.pm | 24 +++++++++++++++++++++--- src/dbHost/DBD/Recfield.pm | 12 +++++++++++- src/dbHost/dbdToRecordtypeH.pl | 15 ++++++++------- 3 files changed, 40 insertions(+), 11 deletions(-) diff --git a/src/dbHost/DBD/Base.pm b/src/dbHost/DBD/Base.pm index e58d9bc26..b6ac2d724 100644 --- a/src/dbHost/DBD/Base.pm +++ b/src/dbHost/DBD/Base.pm @@ -6,9 +6,9 @@ use Carp; require Exporter; @ISA = qw(Exporter); -@EXPORT = qw(&pushContext &popContext &dieContext &warnContext &identifier - &unquote &escapeCcomment &escapeCstring $RXident $RXname $RXuint $RXint - $RXhex $RXoct $RXuintx $RXintx $RXnum $RXdqs $RXsqs $RXstr); +@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 $RXident = qr/ [a-zA-Z] [a-zA-Z0-9_]* /x; @@ -61,6 +61,21 @@ sub unquote (\$) { 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 + do double dynamic_cast else enum explicit export extern false float for + friend goto if inline int long mutable namespace new not not_eq operator or + or_eq private protected public register reinterpret_cast return short signed + sizeof static static_cast struct switch template this throw true try typedef + typeid typename union unsigned using virtual void volatile wchar_t while xor + xor_eq addpath alias breaktable choice device driver field function grecord + include info menu path record recordtype registrar variable); +sub is_reserved { + my $id = shift; + return exists $reserved{$id}; +} + sub identifier { my ($id, $what) = @_; unquote $id; @@ -68,6 +83,9 @@ sub identifier { $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."); + dieContext("Illegal $what '$id'", + "Identifier is a C++ reserved word.") + if is_reserved($id); return $id; } diff --git a/src/dbHost/DBD/Recfield.pm b/src/dbHost/DBD/Recfield.pm index 2b3e38089..259af0eb6 100644 --- a/src/dbHost/DBD/Recfield.pm +++ b/src/dbHost/DBD/Recfield.pm @@ -99,9 +99,19 @@ sub check_valid { if (defined($default) and !$this->legal_value($default)); } +# The C structure member name is usually the field name converted to +# lower-case. However if that is a reserved word, use the original. +sub C_name { + my ($this) = @_; + my $name = lc $this->name; + $name = $this->name + if is_reserved($name); + return $name; +} + sub toDeclaration { my ($this, $ctype) = @_; - my $name = lc $this->name; + my $name = $this->C_name; my $result = sprintf " %-19s %-12s", $ctype, "$name;"; my $prompt = $this->attribute('prompt'); $result .= "/* $prompt */" if defined $prompt; diff --git a/src/dbHost/dbdToRecordtypeH.pl b/src/dbHost/dbdToRecordtypeH.pl index 763f51b44..06d1dd0cc 100755 --- a/src/dbHost/dbdToRecordtypeH.pl +++ b/src/dbHost/dbdToRecordtypeH.pl @@ -122,13 +122,13 @@ sub oldtables { "{\n" . " ${rn}Record *prec = 0;\n" . join("\n", map { - " prt->papFldDes[${rn}Record$_]->size = " . - "sizeof(prec->" . lc($_) . ");" - } $rtyp->field_names) . "\n" . + " prt->papFldDes[${rn}Record" . $_->name . "]->size = " . + "sizeof(prec->" . $_->C_name . ");" + } $rtyp->fields) . "\n" . join("\n", map { - " prt->papFldDes[${rn}Record$_]->offset = " . - "(char *)&prec->" . lc($_) . " - (char *)prec;" - } $rtyp->field_names) . "\n" . + " prt->papFldDes[${rn}Record" . $_->name . "]->offset = " . + "(char *)&prec->" . $_->C_name . " - (char *)prec;" + } $rtyp->fields) . "\n" . " prt->rec_size = sizeof(*prec);\n" . " return 0;\n" . "}\n" . @@ -154,6 +154,7 @@ sub newtables { "static dbFldDes ${rn}FieldMetaData[] = {\n", join(",\n", map { my $fn = $_->name; + my $cn = $_->C_name; " { ${rn}FieldName${fn}," . $_->dbf_type . ',"' . $_->attribute('initial') . '",' . @@ -162,7 +163,7 @@ sub newtables { ($_->attribute('interest') || '0') . ',' . ($_->attribute('asl') || 'ASL0') . ',' . $n++ . ",\n\t\&${rn}RecordMetaData," . - "GEOMETRY_DATA(${rn}Record," . lc($fn) . ') }'; + "GEOMETRY_DATA(${rn}Record,$cn) }"; } $rtyp->fields), "\n};\n\n"; print OUTFILE "static const ${rn}FieldIndex ${rn}RecordLinkFieldIndices[] = {\n", From 64cfd30f62974a1715b10e81301405a8abc6f8db Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 15 Apr 2010 11:32:56 -0500 Subject: [PATCH 21/32] Move Cdefs to the top of the record body. Refine when field attribute values get double-quoted. --- src/dbHost/DBD/Output.pm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/dbHost/DBD/Output.pm b/src/dbHost/DBD/Output.pm index eaff9c45c..c373a3683 100644 --- a/src/dbHost/DBD/Output.pm +++ b/src/dbHost/DBD/Output.pm @@ -42,17 +42,17 @@ sub OutputRecordtypes { my ($out, $recordtypes) = @_; while (my ($name, $recordtype) = each %{$recordtypes}) { printf $out "recordtype(%s) {\n", $name; + print $out " %$_\n" + foreach $recordtype->cdefs; foreach $field ($recordtype->fields) { printf $out " field(%s, %s) {\n", $field->name, $field->dbf_type; while (my ($attr, $val) = each %{$field->attributes}) { - $val = "\"$val\"" if $val =~ m/\s/; + $val = "\"$val\"" if $val !~ m/^[a-zA-Z0-9_\-+:.\[\]<>;]*$/; printf $out " %s(%s)\n", $attr, $val; } print $out " }\n"; } - print $out "% $_\n" - foreach $recordtype->cdefs; printf $out "}\n"; printf $out "device(%s, %s, %s, \"%s\")\n", $name, $_->link_type, $_->name, $_->choice From 03b66fd2cc3e73e8e21aa6a4bd9f121937dfba4c Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 15 Apr 2010 11:37:18 -0500 Subject: [PATCH 22/32] Prettify DBF_NOACCESS fields so definitions line up in record.h file. --- src/ioc/db/dbCommon.dbd | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/ioc/db/dbCommon.dbd b/src/ioc/db/dbCommon.dbd index eb8e7bf35..29d1c0009 100644 --- a/src/ioc/db/dbCommon.dbd +++ b/src/ioc/db/dbCommon.dbd @@ -82,14 +82,14 @@ prompt("Monitor lock") special(SPC_NOMOD) interest(4) - extra("epicsMutexId mlok") + extra("epicsMutexId mlok") } %#include "ellLib.h" field(MLIS,DBF_NOACCESS) { prompt("Monitor List") special(SPC_NOMOD) interest(4) - extra("ELLLIST mlis") + extra("ELLLIST mlis") } field(DISP,DBF_UCHAR) { prompt("Disable putField") @@ -167,13 +167,13 @@ prompt("Access Security Pvt") special(SPC_NOMOD) interest(4) - extra("struct asgMember *asp") + extra("struct asgMember *asp") } field(PPN,DBF_NOACCESS) { prompt("addr of PUTNOTIFY") special(SPC_NOMOD) interest(4) - extra("struct putNotify *ppn") + extra("struct putNotify *ppn") } field(PPNR,DBF_NOACCESS) { prompt("pputNotifyRecord") @@ -191,19 +191,19 @@ prompt("Address of RSET") special(SPC_NOMOD) interest(4) - extra("struct rset *rset") + extra("struct rset *rset") } field(DSET,DBF_NOACCESS) { prompt("DSET address") special(SPC_NOMOD) interest(4) - extra("struct dset *dset") + extra("struct dset *dset") } field(DPVT,DBF_NOACCESS) { prompt("Device Private") special(SPC_NOMOD) interest(4) - extra("void *dpvt") + extra("void *dpvt") } field(RDES,DBF_NOACCESS) { prompt("Address of dbRecordType") @@ -215,7 +215,7 @@ prompt("Lock Set") special(SPC_NOMOD) interest(4) - extra("struct lockRecord *lset") + extra("struct lockRecord *lset") } field(PRIO,DBF_MENU) { prompt("Scheduling Priority") @@ -231,7 +231,7 @@ prompt("Break Point") special(SPC_NOMOD) interest(1) - extra("char bkpt") + extra("char bkpt") } field(UDF,DBF_UCHAR) { prompt("Undefined") @@ -245,7 +245,7 @@ prompt("Time") special(SPC_NOMOD) interest(2) - extra("epicsTimeStamp time") + extra("epicsTimeStamp time") } field(FLNK,DBF_FWDLINK) { prompt("Forward Process Link") From 68f4da301fa6de22c77149187b97e20efcf438fa Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Thu, 15 Apr 2010 11:40:01 -0500 Subject: [PATCH 23/32] Clean up editor backup files too. From 5f027c35b0bfe46ab7f0b2714997e76714feb8be Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Mon, 10 May 2010 15:39:52 -0500 Subject: [PATCH 24/32] Added John Hammonds' dbdToHtml perl script, unmodified. He also wrote: Here is at least a short list of things to think about: How do we add this into the other documentation? How do we add the long description? Modify Readfile to do includes or not? Modify for multiple records in a file? Modify for no records in the file i.e. dbCommon? Automatically add link to menu information if DBF_MENU? Should we go through and set promptgroup on all fields to make this more correct? --- src/dbHost/dbdToHtml | 233 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 233 insertions(+) create mode 100644 src/dbHost/dbdToHtml diff --git a/src/dbHost/dbdToHtml b/src/dbHost/dbdToHtml new file mode 100644 index 000000000..23e063e27 --- /dev/null +++ b/src/dbHost/dbdToHtml @@ -0,0 +1,233 @@ +#!/usr/bin/perl + + +use DBD; +use DBD::Parser; +use Getopts; +use macLib; +use Readfile; + +my $tool = 'dbdToHtml'; +getopts('DI@o:') or + die "Usage: $tool [-D] [-I dir] [-o xRecord.h] xRecord.dbd [xRecord.h]\n"; + +my @path = map { split /[:;]/ } @opt_I; +my $dbd = DBD->new(); + +my $infile = shift @ARGV; +$infile =~ m/\.dbd$/ or + die "$tool: Input file '$infile' must have '.dbd' extension\n"; +my $outfile; +if ($opt_o) { + $outfile = $opt_o; +} elsif (@ARGV) { + $outfile = shift @ARGV; +} else { + ($outfile = $infile) =~ s/\.dbd$/.h/; + $outfile =~ s/^.*\///; + $outfile =~ s/dbCommonRecord/dbCommon/; +} + +print "

$infile


\n"; + +&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I)); + +my $rtypes = $dbd->recordtypes; + +my ($rn, $rtyp) = each %{$rtypes}; +print "

Record Name $rn

\n"; + +my @fields = $rtyp->fields; + +#create a Hash to store the table of field information for each GUI type +%dbdTables = ( + "GUI_COMMON" => "", + "GUI_COMMON" => "", + "GUI_ALARMS" => "", + "GUI_BITS1" => "", + "GUI_BITS2" => "", + "GUI_CALC" => "", + "GUI_CLOCK" => "", + "GUI_COMPRESS" => "", + "GUI_CONVERT" => "", + "GUI_DISPLAY" => "", + "GUI_HIST" => "", + "GUI_INPUTS" => "", + "GUI_LINKS" => "", + "GUI_MBB" => "", + "GUI_MOTOR" => "", + "GUI_OUTPUT" => "", + "GUI_PID" => "", + "GUI_PULSE" => "", + "GUI_SELECT" => "", + "GUI_SEQ1" => "", + "GUI_SEQ2" => "", + "GUI_SEQ3" => "", + "GUI_SUB" => "", + "GUI_TIMER" => "", + "GUI_WAVE" => "", + "GUI_SCAN" => "", + "GUI_NONE" => "" + ); + + +#Loop over all of the fields. Build a string that contains the table body +#for each of the GUI Types based on which fields go with which GUI type. +foreach $fVal (@fields) { + my $pg = $fVal->attribute('promptgroup'); + while ( ($typ1, $content) = each %dbdTables) { + if ( $pg eq $typ1 or ($pg eq "" and $typ1 eq "GUI_NONE")) { + buildTableRow($fVal, $dbdTables{$typ1} ); + } + } +} + +#Write out each table +while ( ($typ2, $content) = each %dbdTables) { + printHtmlTable($typ2, $content); +} + + +#add a field to a table body. The specified field and table body are passed +#in as parameters +sub buildTableRow { + my ( $fld, $outStr) = @_; + $longDesc = " "; + %htmlCellFmt = ( + rowStart => "", + nextCell => "", + endRow => "", + nextRow => "" + ); + my %cellFmt = %htmlCellFmt; + my $rowStart = $cellFmt{rowStart}; + my $nextCell = $cellFmt{nextCell}; + my $endRow = $cellFmt{endRow}; + my $nextRow = $cellFmt{nextRow}; + $outStr = $outStr . $rowStart; + $outStr = $outStr . $fld->name; + $outStr = $outStr . $nextCell; + $outStr = $outStr . $fld->attribute('prompt'); + $outStr = $outStr . $nextCell; + my $recType = $fld->dbf_type; + $typStr = $recType; + if ($recType eq "DBF_STRING") { + $typStr = $recType . " [" . $fld->attribute('size') . "]"; + } + + $outStr = $outStr . $typStr; + $outStr = $outStr . $nextCell; + $outStr = $outStr . design($fld); + $outStr = $outStr . $nextCell; + my $initial = $fld->attribute('initial'); + if ( $initial eq '' ) {$initial = " ";} + $outStr = $outStr . $initial; + $outStr = $outStr . $nextCell; + $outStr = $outStr . readable($fld); + $outStr = $outStr . $nextCell; + $outStr = $outStr . writable($fld); + $outStr = $outStr . $nextCell; + $outStr = $outStr . processPassive($fld); + $outStr = $outStr . $endRow; + $outStr = $outStr . "\n"; + $outStr = $outStr . $nextRow; + $outStr = $outStr . $longDesc; + $outStr = $outStr . $endRow; + $outStr = $outStr . "\n"; + $_[1] = $outStr; +} + +#Check if the prompt group is defined so that this can be used by clients +sub design { + my $fld = $_[0]; + my $pg = $fld->attribute('promptgroup'); + if ( $pg eq '' ) { + my $result = 'No'; + } + else { + my $result = 'Yes'; + } +} + +#Check if this field is readable by clients +sub readable { + my $fld = $_[0]; + if ( $fld->attribute('special') eq "SPC_DBADDR") { + $return = "Probably"; + } + else{ + if ( $fld->dbf_type eq "DBF_NOACCESS" ) { + $return = "No"; + } + else { + $return = "Yes" + } + } +} + +#Check if this field is writable by clients +sub writable { + my $fld = $_[0]; + my $spec = $fld->attribute('special'); + if ( $spec eq "SPC_NOMOD" ) { + $return = "No"; + } + else { + if ( $spec ne "SPC_DBADDR") { + if ( $fld->dbf_type eq "DBF_NOACCESS" ) { + $return = "No"; + } + else { + $return = "Yes"; + } + } + else { + $return = "Maybe"; + } + } +} + + +#Check to see if the field is process passive on caput +sub processPassive { + my $fld = $_[0]; + $pp = $fld->attribute('pp'); + if ( $pp eq "YES" or $pp eq "TRUE" ) { + $result = "Yes"; + } + elsif ( $PP eq "NO" or $pp eq "FALSE" or $pp eq "" ) { + $result = "No"; + } +} + +#print the start row to define a table +sub printTableStart { + print " \n"; + print ""; + print "\n"; + print "\n"; + print "\n"; + print "\n"; + print "\n"; + print "\n"; + print "\n"; + print "\n"; + +} + +#print the tail end of the table +sub printTableEnd { + print "
$_[0]
FieldSummaryTypeDCTDefaultReadWritecaPut=PP
\n"; +} + +# Print the table for a GUI type. The name of the GUI type and the Table body +# for this type are fed in as parameters +sub printHtmlTable { + my ($typ2, $content) = $_; + if ( (length $_[1]) gt 0) { + printTableStart($_[0]); + print "$_[1]\n"; + printTableEnd(); + } + +} From adbf7a73889b848aac79cfa505ca69d58b23e9a8 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Mon, 10 May 2010 15:59:39 -0500 Subject: [PATCH 25/32] Update to current code: * Added (c) header, expanded tabs * Set library path and use new library names * Added -D (dependency) output handling * Added -o (output file) support * Use instead of for normal cell data This is by no means complete, but it does seem to work. --- src/dbHost/Makefile | 1 + src/dbHost/{dbdToHtml => dbdToHtml.pl} | 201 ++++++++++++++----------- 2 files changed, 111 insertions(+), 91 deletions(-) rename src/dbHost/{dbdToHtml => dbdToHtml.pl} (51%) diff --git a/src/dbHost/Makefile b/src/dbHost/Makefile index 927d8f53c..465c910ac 100644 --- a/src/dbHost/Makefile +++ b/src/dbHost/Makefile @@ -24,6 +24,7 @@ PERL_MODULES += DBD/Variable.pm PERL_SCRIPTS += dbdToMenuH.pl PERL_SCRIPTS += dbdToRecordtypeH.pl PERL_SCRIPTS += dbdExpand.pl +PERL_SCRIPTS += dbdToHtml.pl include $(TOP)/configure/RULES diff --git a/src/dbHost/dbdToHtml b/src/dbHost/dbdToHtml.pl similarity index 51% rename from src/dbHost/dbdToHtml rename to src/dbHost/dbdToHtml.pl index 23e063e27..a6fb69dfc 100644 --- a/src/dbHost/dbdToHtml +++ b/src/dbHost/dbdToHtml.pl @@ -1,15 +1,26 @@ #!/usr/bin/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 FindBin qw($Bin); +use lib "$Bin/../../lib/perl"; use DBD; use DBD::Parser; -use Getopts; -use macLib; +use EPICS::Getopts; +use EPICS::macLib; use Readfile; my $tool = 'dbdToHtml'; getopts('DI@o:') or - die "Usage: $tool [-D] [-I dir] [-o xRecord.h] xRecord.dbd [xRecord.h]\n"; + die "Usage: $tool [-D] [-I dir] [-o xRecord.html] xRecord.dbd\n"; my @path = map { split /[:;]/ } @opt_I; my $dbd = DBD->new(); @@ -17,58 +28,66 @@ my $dbd = DBD->new(); my $infile = shift @ARGV; $infile =~ m/\.dbd$/ or die "$tool: Input file '$infile' must have '.dbd' extension\n"; -my $outfile; -if ($opt_o) { - $outfile = $opt_o; -} elsif (@ARGV) { - $outfile = shift @ARGV; -} else { - ($outfile = $infile) =~ s/\.dbd$/.h/; - $outfile =~ s/^.*\///; - $outfile =~ s/dbCommonRecord/dbCommon/; -} - -print "

$infile


\n"; &ParseDBD($dbd, &Readfile($infile, 0, \@opt_I)); +if ($opt_D) { # Output dependencies only + my %filecount; + my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles; + print "$opt_o: ", join(" \\\n ", @uniqfiles), "\n\n"; + print map { "$_:\n" } @uniqfiles; + exit 0; +} + +my $out; +if ($opt_o) { + $out = $opt_o; +} else { + ($out = $infile) =~ s/\.dbd$/.html/; + $out =~ s/^.*\///; + $out =~ s/dbCommonRecord/dbCommon/; +} +open $out, '>', $opt_o or die "Can't create $opt_o: $!\n"; + +print $out "

$infile

\n"; + my $rtypes = $dbd->recordtypes; my ($rn, $rtyp) = each %{$rtypes}; -print "

Record Name $rn

\n"; +print $out "

Record Name $rn

\n"; my @fields = $rtyp->fields; #create a Hash to store the table of field information for each GUI type %dbdTables = ( - "GUI_COMMON" => "", - "GUI_COMMON" => "", - "GUI_ALARMS" => "", - "GUI_BITS1" => "", - "GUI_BITS2" => "", - "GUI_CALC" => "", - "GUI_CLOCK" => "", - "GUI_COMPRESS" => "", - "GUI_CONVERT" => "", - "GUI_DISPLAY" => "", - "GUI_HIST" => "", - "GUI_INPUTS" => "", - "GUI_LINKS" => "", - "GUI_MBB" => "", - "GUI_MOTOR" => "", - "GUI_OUTPUT" => "", - "GUI_PID" => "", - "GUI_PULSE" => "", - "GUI_SELECT" => "", - "GUI_SEQ1" => "", - "GUI_SEQ2" => "", - "GUI_SEQ3" => "", - "GUI_SUB" => "", - "GUI_TIMER" => "", - "GUI_WAVE" => "", - "GUI_SCAN" => "", - "GUI_NONE" => "" - ); + "GUI_COMMON" => "", + "GUI_COMMON" => "", + "GUI_ALARMS" => "", + "GUI_BITS1" => "", + "GUI_BITS2" => "", + "GUI_CALC" => "", + "GUI_CLOCK" => "", + "GUI_COMPRESS" => "", + "GUI_CONVERT" => "", + "GUI_DISPLAY" => "", + "GUI_HIST" => "", + "GUI_INPUTS" => "", + "GUI_LINKS" => "", + "GUI_MBB" => "", + "GUI_MOTOR" => "", + "GUI_OUTPUT" => "", + "GUI_PID" => "", + "GUI_PULSE" => "", + "GUI_SELECT" => "", + "GUI_SEQ1" => "", + "GUI_SEQ2" => "", + "GUI_SEQ3" => "", + "GUI_SUB" => "", + "GUI_TIMER" => "", + "GUI_WAVE" => "", + "GUI_SCAN" => "", + "GUI_NONE" => "" +); #Loop over all of the fields. Build a string that contains the table body @@ -76,9 +95,9 @@ my @fields = $rtyp->fields; foreach $fVal (@fields) { my $pg = $fVal->attribute('promptgroup'); while ( ($typ1, $content) = each %dbdTables) { - if ( $pg eq $typ1 or ($pg eq "" and $typ1 eq "GUI_NONE")) { - buildTableRow($fVal, $dbdTables{$typ1} ); - } + if ( $pg eq $typ1 or ($pg eq "" and $typ1 eq "GUI_NONE")) { + buildTableRow($fVal, $dbdTables{$typ1} ); + } } } @@ -92,12 +111,12 @@ while ( ($typ2, $content) = each %dbdTables) { #in as parameters sub buildTableRow { my ( $fld, $outStr) = @_; - $longDesc = " "; + $longDesc = " "; %htmlCellFmt = ( - rowStart => "", - nextCell => "", - endRow => "", - nextRow => "" + rowStart => "", + nextCell => "", + endRow => "", + nextRow => "" ); my %cellFmt = %htmlCellFmt; my $rowStart = $cellFmt{rowStart}; @@ -111,8 +130,8 @@ sub buildTableRow { $outStr = $outStr . $nextCell; my $recType = $fld->dbf_type; $typStr = $recType; - if ($recType eq "DBF_STRING") { - $typStr = $recType . " [" . $fld->attribute('size') . "]"; + if ($recType eq "DBF_STRING") { + $typStr = $recType . " [" . $fld->attribute('size') . "]"; } $outStr = $outStr . $typStr; @@ -120,7 +139,7 @@ sub buildTableRow { $outStr = $outStr . design($fld); $outStr = $outStr . $nextCell; my $initial = $fld->attribute('initial'); - if ( $initial eq '' ) {$initial = " ";} + if ( $initial eq '' ) {$initial = " ";} $outStr = $outStr . $initial; $outStr = $outStr . $nextCell; $outStr = $outStr . readable($fld); @@ -142,7 +161,7 @@ sub design { my $fld = $_[0]; my $pg = $fld->attribute('promptgroup'); if ( $pg eq '' ) { - my $result = 'No'; + my $result = 'No'; } else { my $result = 'Yes'; @@ -153,15 +172,15 @@ sub design { sub readable { my $fld = $_[0]; if ( $fld->attribute('special') eq "SPC_DBADDR") { - $return = "Probably"; + $return = "Probably"; } else{ - if ( $fld->dbf_type eq "DBF_NOACCESS" ) { - $return = "No"; - } - else { - $return = "Yes" - } + if ( $fld->dbf_type eq "DBF_NOACCESS" ) { + $return = "No"; + } + else { + $return = "Yes" + } } } @@ -170,20 +189,20 @@ sub writable { my $fld = $_[0]; my $spec = $fld->attribute('special'); if ( $spec eq "SPC_NOMOD" ) { - $return = "No"; + $return = "No"; } else { - if ( $spec ne "SPC_DBADDR") { - if ( $fld->dbf_type eq "DBF_NOACCESS" ) { - $return = "No"; - } - else { - $return = "Yes"; - } - } - else { - $return = "Maybe"; - } + if ( $spec ne "SPC_DBADDR") { + if ( $fld->dbf_type eq "DBF_NOACCESS" ) { + $return = "No"; + } + else { + $return = "Yes"; + } + } + else { + $return = "Maybe"; + } } } @@ -193,31 +212,31 @@ sub processPassive { my $fld = $_[0]; $pp = $fld->attribute('pp'); if ( $pp eq "YES" or $pp eq "TRUE" ) { - $result = "Yes"; + $result = "Yes"; } elsif ( $PP eq "NO" or $pp eq "FALSE" or $pp eq "" ) { - $result = "No"; + $result = "No"; } } #print the start row to define a table sub printTableStart { - print " \n"; - print ""; - print "\n"; - print "\n"; - print "\n"; - print "\n"; - print "\n"; - print "\n"; - print "\n"; - print "\n"; + print $out "
$_[0]
FieldSummaryTypeDCTDefaultReadWritecaPut=PP
\n"; + print $out ""; + print $out "\n"; + print $out "\n"; + print $out "\n"; + print $out "\n"; + print $out "\n"; + print $out "\n"; + print $out "\n"; + print $out "\n"; } #print the tail end of the table sub printTableEnd { - print "
$_[0]
FieldSummaryTypeDCTDefaultReadWritecaPut=PP
\n"; + print $out "\n"; } # Print the table for a GUI type. The name of the GUI type and the Table body @@ -225,9 +244,9 @@ sub printTableEnd { sub printHtmlTable { my ($typ2, $content) = $_; if ( (length $_[1]) gt 0) { - printTableStart($_[0]); - print "$_[1]\n"; - printTableEnd(); + printTableStart($_[0]); + print $out "$_[1]\n"; + printTableEnd(); } } From 63f5c27ebef9619643fcb6ca6d910b87b04320eb Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Tue, 13 Mar 2012 16:02:24 -0500 Subject: [PATCH 26/32] Fix tests, use EPICS::Readfile --- src/dbHost/dbdReport | 2 +- src/dbHost/dbdToHtml.pl | 2 +- src/dbHost/test/Recfield.pl | 14 +++++++------- src/dbHost/test/macLib.pl | 9 ++++++--- 4 files changed, 15 insertions(+), 12 deletions(-) diff --git a/src/dbHost/dbdReport b/src/dbHost/dbdReport index bd6cd5a32..303782879 100755 --- a/src/dbHost/dbdReport +++ b/src/dbHost/dbdReport @@ -16,7 +16,7 @@ use DBD; use DBD::Parser; use EPICS::Getopts; use EPICS::macLib; -use Readfile; +use EPICS::Readfile; use Text::Wrap; #$EPICS::Readfile::debug = 1; diff --git a/src/dbHost/dbdToHtml.pl b/src/dbHost/dbdToHtml.pl index a6fb69dfc..936cbf48c 100644 --- a/src/dbHost/dbdToHtml.pl +++ b/src/dbHost/dbdToHtml.pl @@ -16,7 +16,7 @@ use DBD; use DBD::Parser; use EPICS::Getopts; use EPICS::macLib; -use Readfile; +use EPICS::Readfile; my $tool = 'dbdToHtml'; getopts('DI@o:') or diff --git a/src/dbHost/test/Recfield.pl b/src/dbHost/test/Recfield.pl index 92833ecd3..45f4e455c 100644 --- a/src/dbHost/test/Recfield.pl +++ b/src/dbHost/test/Recfield.pl @@ -26,7 +26,7 @@ ok $fld_char->legal_value("-128"), 'Legal - value'; ok $fld_char->legal_value("127"), 'Legal + value'; ok !$fld_char->legal_value("0x80"), 'Illegal + hex value'; $fld_char->check_valid; -like $fld_char->toDeclaration, qr/^\s*signed\s+char\s+chr;\s*$/, "C declaration"; +like $fld_char->toDeclaration, qr/^\s*epicsInt8\s+chr;\s*$/, "C declaration"; my $fld_uchar = DBD::Recfield->new('uchr', 'DBF_UCHAR'); isa_ok $fld_uchar, 'DBD::Recfield'; @@ -38,7 +38,7 @@ ok $fld_uchar->legal_value("0"), 'Legal 0 value'; ok $fld_uchar->legal_value("0377"), 'Legal + value'; ok !$fld_uchar->legal_value("0400"), 'Illegal + octal value'; $fld_uchar->check_valid; -like $fld_uchar->toDeclaration, qr/^\s*unsigned\s+char\s+uchr;\s*$/, "C declaration"; +like $fld_uchar->toDeclaration, qr/^\s*epicsUInt8\s+uchr;\s*$/, "C declaration"; my $fld_short = DBD::Recfield->new('shrt', 'DBF_SHORT'); isa_ok $fld_short, 'DBD::Recfield'; @@ -50,7 +50,7 @@ ok $fld_short->legal_value("-32768"), 'Legal - value'; ok $fld_short->legal_value("32767"), 'Legal + value'; ok !$fld_short->legal_value("0x8000"), 'Illegal + hex value'; $fld_short->check_valid; -like $fld_short->toDeclaration, qr/^\s*short\s+shrt;\s*$/, "C declaration"; +like $fld_short->toDeclaration, qr/^\s*epicsInt16\s+shrt;\s*$/, "C declaration"; my $fld_ushort = DBD::Recfield->new('ushrt', 'DBF_USHORT'); isa_ok $fld_ushort, 'DBD::Recfield'; @@ -62,7 +62,7 @@ ok $fld_ushort->legal_value("0"), 'Legal 0 value'; ok $fld_ushort->legal_value("65535"), 'Legal + value'; ok !$fld_ushort->legal_value("0x10000"), 'Illegal + hex value'; $fld_ushort->check_valid; -like $fld_ushort->toDeclaration, qr/^\s*unsigned\s+short\s+ushrt;\s*$/, "C declaration"; +like $fld_ushort->toDeclaration, qr/^\s*epicsUInt16\s+ushrt;\s*$/, "C declaration"; my $fld_long = DBD::Recfield->new('lng', 'DBF_LONG'); isa_ok $fld_long, 'DBD::Recfield'; @@ -85,7 +85,7 @@ ok $fld_ulong->legal_value("00"), 'Legal 0 value'; ok $fld_ulong->legal_value("0xffffffff"), 'Legal + value'; ok !$fld_ulong->legal_value("0xfacepaint"), 'Illegal value'; $fld_ulong->check_valid; -like $fld_ulong->toDeclaration, qr/^\s*unsigned\s+long\s+ulng;\s*$/, "C declaration"; +like $fld_ulong->toDeclaration, qr/^\s*epicsUInt32\s+ulng;\s*$/, "C declaration"; my $fld_float = DBD::Recfield->new('flt', 'DBF_FLOAT'); isa_ok $fld_float, 'DBD::Recfield'; @@ -96,7 +96,7 @@ ok $fld_float->legal_value("-1.2345678e9"), 'Legal - value'; ok $fld_float->legal_value("0.12345678e9"), 'Legal + value'; ok !$fld_float->legal_value("0x1.5"), 'Illegal value'; $fld_float->check_valid; -like $fld_float->toDeclaration, qr/^\s*float\s+flt;\s*$/, "C declaration"; +like $fld_float->toDeclaration, qr/^\s*epicsFloat32\s+flt;\s*$/, "C declaration"; my $fld_double = DBD::Recfield->new('dbl', 'DBF_DOUBLE'); isa_ok $fld_double, 'DBD::Recfield'; @@ -107,5 +107,5 @@ ok $fld_double->legal_value("-12345e-67"), 'Legal - value'; ok $fld_double->legal_value("12345678e+9"), 'Legal + value'; ok !$fld_double->legal_value("e5"), 'Illegal value'; $fld_double->check_valid; -like $fld_double->toDeclaration, qr/^\s*double\s+dbl;\s*$/, "C declaration"; +like $fld_double->toDeclaration, qr/^\s*epicsFloat64\s+dbl;\s*$/, "C declaration"; diff --git a/src/dbHost/test/macLib.pl b/src/dbHost/test/macLib.pl index db0a3122b..e8419baa6 100644 --- a/src/dbHost/test/macLib.pl +++ b/src/dbHost/test/macLib.pl @@ -1,13 +1,16 @@ #!/usr/bin/perl +use FindBin qw($Bin); +use lib "$Bin/../../../lib/perl"; + use Test::More tests => 34; -use macLib; +use EPICS::macLib; use Data::Dumper; -my $m = macLib->new; -isa_ok $m, 'macLib'; +my $m = EPICS::macLib->new; +isa_ok $m, 'EPICS::macLib'; is $m->expandString(''), '', 'Empty string'; is $m->expandString('$(undef)'), undef, 'Warning $(undef)'; From 36b8d61a417df802961d58f8453be1b811befeac Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Tue, 13 Mar 2012 17:50:36 -0500 Subject: [PATCH 27/32] Remove dependency on conversion dbTo* programs. Doesn't work anyway since they're now Perl scripts, but isn't necessary because dbHost gets built first. --- src/ioc/db/RULES | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/ioc/db/RULES b/src/ioc/db/RULES index 14a421e5c..7ba979e70 100644 --- a/src/ioc/db/RULES +++ b/src/ioc/db/RULES @@ -20,9 +20,3 @@ dbCommon.h$(DEP): $(IOCDIR)/db/dbCommonRecord.dbd $(IOCDIR)/db/dbCommon.dbd $(COMMON_DIR)/dbCommon.h: $(IOCDIR)/db/dbCommonRecord.dbd $(IOCDIR)/db/dbCommon.dbd $(RM) $@ $(DBTORECORDTYPEH) -I ../db $< $@ - -$(COMMON_DIR)/dbCommon.h: $(DBTORECORDTYPEH) - -$(patsubst %,$(COMMON_DIR)/%.h,$(DBDINC) menuConvert menuGlobal) : \ -$(COMMON_DIR)/%.h : $(DBTOMENUH) - From d3d8418855db8d60383b13abf70b6e6c1204b931 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Tue, 13 Mar 2012 18:00:46 -0500 Subject: [PATCH 28/32] Move src/dbHost scripts and modules into src/tools. --- src/Makefile | 3 -- src/dbHost/Makefile | 30 -------------------- src/{dbHost => tools}/DBD.pm | 0 src/{dbHost => tools}/DBD/Base.pm | 0 src/{dbHost => tools}/DBD/Breaktable.pm | 0 src/{dbHost => tools}/DBD/Device.pm | 0 src/{dbHost => tools}/DBD/Driver.pm | 0 src/{dbHost => tools}/DBD/Function.pm | 0 src/{dbHost => tools}/DBD/Menu.pm | 0 src/{dbHost => tools}/DBD/Output.pm | 0 src/{dbHost => tools}/DBD/Parser.pm | 0 src/{dbHost => tools}/DBD/Recfield.pm | 0 src/{dbHost => tools}/DBD/Recordtype.pm | 0 src/{dbHost => tools}/DBD/Registrar.pm | 0 src/{dbHost => tools}/DBD/Variable.pm | 0 src/tools/Makefile | 21 +++++++++++++- src/{dbHost => tools}/dbdExpand.pl | 0 src/{dbHost/dbdReport => tools/dbdReport.pl} | 0 src/{dbHost => tools}/dbdToHtml.pl | 0 src/{dbHost => tools}/dbdToMenuH.pl | 0 src/{dbHost => tools}/dbdToRecordtypeH.pl | 0 src/{dbHost => tools}/test/Breaktable.pl | 0 src/{dbHost => tools}/test/DBD.pl | 0 src/{dbHost => tools}/test/Device.pl | 0 src/{dbHost => tools}/test/Driver.pl | 0 src/{dbHost => tools}/test/Function.pl | 0 src/{dbHost => tools}/test/Menu.pl | 0 src/{dbHost => tools}/test/Recfield.pl | 0 src/{dbHost => tools}/test/Recordtype.pl | 0 src/{dbHost => tools}/test/Registrar.pl | 0 src/{dbHost => tools}/test/Variable.pl | 0 src/{dbHost => tools}/test/macLib.pl | 0 32 files changed, 20 insertions(+), 34 deletions(-) delete mode 100644 src/dbHost/Makefile rename src/{dbHost => tools}/DBD.pm (100%) rename src/{dbHost => tools}/DBD/Base.pm (100%) rename src/{dbHost => tools}/DBD/Breaktable.pm (100%) rename src/{dbHost => tools}/DBD/Device.pm (100%) rename src/{dbHost => tools}/DBD/Driver.pm (100%) rename src/{dbHost => tools}/DBD/Function.pm (100%) rename src/{dbHost => tools}/DBD/Menu.pm (100%) rename src/{dbHost => tools}/DBD/Output.pm (100%) rename src/{dbHost => tools}/DBD/Parser.pm (100%) rename src/{dbHost => tools}/DBD/Recfield.pm (100%) rename src/{dbHost => tools}/DBD/Recordtype.pm (100%) rename src/{dbHost => tools}/DBD/Registrar.pm (100%) rename src/{dbHost => tools}/DBD/Variable.pm (100%) rename src/{dbHost => tools}/dbdExpand.pl (100%) rename src/{dbHost/dbdReport => tools/dbdReport.pl} (100%) rename src/{dbHost => tools}/dbdToHtml.pl (100%) rename src/{dbHost => tools}/dbdToMenuH.pl (100%) rename src/{dbHost => tools}/dbdToRecordtypeH.pl (100%) rename src/{dbHost => tools}/test/Breaktable.pl (100%) rename src/{dbHost => tools}/test/DBD.pl (100%) rename src/{dbHost => tools}/test/Device.pl (100%) rename src/{dbHost => tools}/test/Driver.pl (100%) rename src/{dbHost => tools}/test/Function.pl (100%) rename src/{dbHost => tools}/test/Menu.pl (100%) rename src/{dbHost => tools}/test/Recfield.pl (100%) rename src/{dbHost => tools}/test/Recordtype.pl (100%) rename src/{dbHost => tools}/test/Registrar.pl (100%) rename src/{dbHost => tools}/test/Variable.pl (100%) rename src/{dbHost => tools}/test/macLib.pl (100%) diff --git a/src/Makefile b/src/Makefile index b370c1d50..88a03d7c6 100644 --- a/src/Makefile +++ b/src/Makefile @@ -23,9 +23,6 @@ template/ext_DEPEND_DIRS = tools # Common -DIRS += dbHost -dbHost_DEPEND_DIRS = tools - DIRS += libCom libCom_DEPEND_DIRS = tools diff --git a/src/dbHost/Makefile b/src/dbHost/Makefile deleted file mode 100644 index 465c910ac..000000000 --- a/src/dbHost/Makefile +++ /dev/null @@ -1,30 +0,0 @@ -#************************************************************************* -# Copyright (c) 2009 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. -#************************************************************************* -TOP=../.. -include $(TOP)/configure/CONFIG - -PERL_MODULES += DBD.pm -PERL_MODULES += DBD/Base.pm -PERL_MODULES += DBD/Breaktable.pm -PERL_MODULES += DBD/Device.pm -PERL_MODULES += DBD/Driver.pm -PERL_MODULES += DBD/Function.pm -PERL_MODULES += DBD/Menu.pm -PERL_MODULES += DBD/Output.pm -PERL_MODULES += DBD/Parser.pm -PERL_MODULES += DBD/Recfield.pm -PERL_MODULES += DBD/Recordtype.pm -PERL_MODULES += DBD/Registrar.pm -PERL_MODULES += DBD/Variable.pm - -PERL_SCRIPTS += dbdToMenuH.pl -PERL_SCRIPTS += dbdToRecordtypeH.pl -PERL_SCRIPTS += dbdExpand.pl -PERL_SCRIPTS += dbdToHtml.pl - -include $(TOP)/configure/RULES - diff --git a/src/dbHost/DBD.pm b/src/tools/DBD.pm similarity index 100% rename from src/dbHost/DBD.pm rename to src/tools/DBD.pm diff --git a/src/dbHost/DBD/Base.pm b/src/tools/DBD/Base.pm similarity index 100% rename from src/dbHost/DBD/Base.pm rename to src/tools/DBD/Base.pm diff --git a/src/dbHost/DBD/Breaktable.pm b/src/tools/DBD/Breaktable.pm similarity index 100% rename from src/dbHost/DBD/Breaktable.pm rename to src/tools/DBD/Breaktable.pm diff --git a/src/dbHost/DBD/Device.pm b/src/tools/DBD/Device.pm similarity index 100% rename from src/dbHost/DBD/Device.pm rename to src/tools/DBD/Device.pm diff --git a/src/dbHost/DBD/Driver.pm b/src/tools/DBD/Driver.pm similarity index 100% rename from src/dbHost/DBD/Driver.pm rename to src/tools/DBD/Driver.pm diff --git a/src/dbHost/DBD/Function.pm b/src/tools/DBD/Function.pm similarity index 100% rename from src/dbHost/DBD/Function.pm rename to src/tools/DBD/Function.pm diff --git a/src/dbHost/DBD/Menu.pm b/src/tools/DBD/Menu.pm similarity index 100% rename from src/dbHost/DBD/Menu.pm rename to src/tools/DBD/Menu.pm diff --git a/src/dbHost/DBD/Output.pm b/src/tools/DBD/Output.pm similarity index 100% rename from src/dbHost/DBD/Output.pm rename to src/tools/DBD/Output.pm diff --git a/src/dbHost/DBD/Parser.pm b/src/tools/DBD/Parser.pm similarity index 100% rename from src/dbHost/DBD/Parser.pm rename to src/tools/DBD/Parser.pm diff --git a/src/dbHost/DBD/Recfield.pm b/src/tools/DBD/Recfield.pm similarity index 100% rename from src/dbHost/DBD/Recfield.pm rename to src/tools/DBD/Recfield.pm diff --git a/src/dbHost/DBD/Recordtype.pm b/src/tools/DBD/Recordtype.pm similarity index 100% rename from src/dbHost/DBD/Recordtype.pm rename to src/tools/DBD/Recordtype.pm diff --git a/src/dbHost/DBD/Registrar.pm b/src/tools/DBD/Registrar.pm similarity index 100% rename from src/dbHost/DBD/Registrar.pm rename to src/tools/DBD/Registrar.pm diff --git a/src/dbHost/DBD/Variable.pm b/src/tools/DBD/Variable.pm similarity index 100% rename from src/dbHost/DBD/Variable.pm rename to src/tools/DBD/Variable.pm diff --git a/src/tools/Makefile b/src/tools/Makefile index 73a70cf88..8d306f4e8 100644 --- a/src/tools/Makefile +++ b/src/tools/Makefile @@ -1,5 +1,5 @@ #************************************************************************* -# Copyright (c) 2008 UChicago Argonne LLC, as Operator of Argonne +# Copyright (c) 2012 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. @@ -18,6 +18,20 @@ PERL_MODULES += EPICS/Readfile.pm PERL_MODULES += EPICS/Getopts.pm PERL_MODULES += EPICS/macLib.pm +PERL_MODULES += DBD.pm +PERL_MODULES += DBD/Base.pm +PERL_MODULES += DBD/Breaktable.pm +PERL_MODULES += DBD/Device.pm +PERL_MODULES += DBD/Driver.pm +PERL_MODULES += DBD/Function.pm +PERL_MODULES += DBD/Menu.pm +PERL_MODULES += DBD/Output.pm +PERL_MODULES += DBD/Parser.pm +PERL_MODULES += DBD/Recfield.pm +PERL_MODULES += DBD/Recordtype.pm +PERL_MODULES += DBD/Registrar.pm +PERL_MODULES += DBD/Variable.pm + PERL_SCRIPTS += convertRelease.pl PERL_SCRIPTS += cvsclean.pl PERL_SCRIPTS += dos2unix.pl @@ -34,5 +48,10 @@ PERL_SCRIPTS += munch.pl PERL_SCRIPTS += replaceVAR.pl PERL_SCRIPTS += useManifestTool.pl +PERL_SCRIPTS += dbdToMenuH.pl +PERL_SCRIPTS += dbdToRecordtypeH.pl +PERL_SCRIPTS += dbdExpand.pl +PERL_SCRIPTS += dbdToHtml.pl + include $(TOP)/configure/RULES diff --git a/src/dbHost/dbdExpand.pl b/src/tools/dbdExpand.pl similarity index 100% rename from src/dbHost/dbdExpand.pl rename to src/tools/dbdExpand.pl diff --git a/src/dbHost/dbdReport b/src/tools/dbdReport.pl similarity index 100% rename from src/dbHost/dbdReport rename to src/tools/dbdReport.pl diff --git a/src/dbHost/dbdToHtml.pl b/src/tools/dbdToHtml.pl similarity index 100% rename from src/dbHost/dbdToHtml.pl rename to src/tools/dbdToHtml.pl diff --git a/src/dbHost/dbdToMenuH.pl b/src/tools/dbdToMenuH.pl similarity index 100% rename from src/dbHost/dbdToMenuH.pl rename to src/tools/dbdToMenuH.pl diff --git a/src/dbHost/dbdToRecordtypeH.pl b/src/tools/dbdToRecordtypeH.pl similarity index 100% rename from src/dbHost/dbdToRecordtypeH.pl rename to src/tools/dbdToRecordtypeH.pl diff --git a/src/dbHost/test/Breaktable.pl b/src/tools/test/Breaktable.pl similarity index 100% rename from src/dbHost/test/Breaktable.pl rename to src/tools/test/Breaktable.pl diff --git a/src/dbHost/test/DBD.pl b/src/tools/test/DBD.pl similarity index 100% rename from src/dbHost/test/DBD.pl rename to src/tools/test/DBD.pl diff --git a/src/dbHost/test/Device.pl b/src/tools/test/Device.pl similarity index 100% rename from src/dbHost/test/Device.pl rename to src/tools/test/Device.pl diff --git a/src/dbHost/test/Driver.pl b/src/tools/test/Driver.pl similarity index 100% rename from src/dbHost/test/Driver.pl rename to src/tools/test/Driver.pl diff --git a/src/dbHost/test/Function.pl b/src/tools/test/Function.pl similarity index 100% rename from src/dbHost/test/Function.pl rename to src/tools/test/Function.pl diff --git a/src/dbHost/test/Menu.pl b/src/tools/test/Menu.pl similarity index 100% rename from src/dbHost/test/Menu.pl rename to src/tools/test/Menu.pl diff --git a/src/dbHost/test/Recfield.pl b/src/tools/test/Recfield.pl similarity index 100% rename from src/dbHost/test/Recfield.pl rename to src/tools/test/Recfield.pl diff --git a/src/dbHost/test/Recordtype.pl b/src/tools/test/Recordtype.pl similarity index 100% rename from src/dbHost/test/Recordtype.pl rename to src/tools/test/Recordtype.pl diff --git a/src/dbHost/test/Registrar.pl b/src/tools/test/Registrar.pl similarity index 100% rename from src/dbHost/test/Registrar.pl rename to src/tools/test/Registrar.pl diff --git a/src/dbHost/test/Variable.pl b/src/tools/test/Variable.pl similarity index 100% rename from src/dbHost/test/Variable.pl rename to src/tools/test/Variable.pl diff --git a/src/dbHost/test/macLib.pl b/src/tools/test/macLib.pl similarity index 100% rename from src/dbHost/test/macLib.pl rename to src/tools/test/macLib.pl From 116f0fd00c2f2e4b86684b15ebe76d430dfbc62b Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Wed, 14 Mar 2012 15:27:40 -0500 Subject: [PATCH 29/32] Run the tools/test files under the test harness --- src/Makefile | 3 +++ .../test/{Breaktable.pl => Breaktable.plt} | 3 +++ src/tools/test/{DBD.pl => DBD.plt} | 3 +++ src/tools/test/{Device.pl => Device.plt} | 3 +++ src/tools/test/{Driver.pl => Driver.plt} | 3 +++ src/tools/test/{Function.pl => Function.plt} | 3 +++ src/tools/test/Makefile | 26 +++++++++++++++++++ src/tools/test/{Menu.pl => Menu.plt} | 3 +++ src/tools/test/{Recfield.pl => Recfield.plt} | 3 +++ .../test/{Recordtype.pl => Recordtype.plt} | 3 +++ .../test/{Registrar.pl => Registrar.plt} | 3 +++ src/tools/test/{Variable.pl => Variable.plt} | 3 +++ src/tools/test/{macLib.pl => macLib.plt} | 2 +- 13 files changed, 60 insertions(+), 1 deletion(-) rename src/tools/test/{Breaktable.pl => Breaktable.plt} (90%) rename src/tools/test/{DBD.pl => DBD.plt} (96%) rename src/tools/test/{Device.pl => Device.plt} (93%) rename src/tools/test/{Driver.pl => Driver.plt} (73%) rename src/tools/test/{Function.pl => Function.plt} (74%) create mode 100644 src/tools/test/Makefile rename src/tools/test/{Menu.pl => Menu.plt} (94%) rename src/tools/test/{Recfield.pl => Recfield.plt} (98%) rename src/tools/test/{Recordtype.pl => Recordtype.plt} (95%) rename src/tools/test/{Registrar.pl => Registrar.plt} (74%) rename src/tools/test/{Variable.pl => Variable.plt} (84%) rename src/tools/test/{macLib.pl => macLib.plt} (98%) diff --git a/src/Makefile b/src/Makefile index 88a03d7c6..ad00bc90b 100644 --- a/src/Makefile +++ b/src/Makefile @@ -15,6 +15,9 @@ include $(TOP)/configure/CONFIG DIRS += tools +DIRS += tools/test +tools/test_DEPEND_DIRS = tools + DIRS += template/base template/base_DEPEND_DIRS = tools diff --git a/src/tools/test/Breaktable.pl b/src/tools/test/Breaktable.plt similarity index 90% rename from src/tools/test/Breaktable.pl rename to src/tools/test/Breaktable.plt index 09285491a..36085d331 100644 --- a/src/tools/test/Breaktable.pl +++ b/src/tools/test/Breaktable.plt @@ -1,5 +1,8 @@ #!/usr/bin/perl +use FindBin qw($Bin); +use lib "$Bin/../../../../lib/perl"; + use Test::More tests => 9; use DBD::Breaktable; diff --git a/src/tools/test/DBD.pl b/src/tools/test/DBD.plt similarity index 96% rename from src/tools/test/DBD.pl rename to src/tools/test/DBD.plt index d79341946..d6e5676da 100644 --- a/src/tools/test/DBD.pl +++ b/src/tools/test/DBD.plt @@ -1,5 +1,8 @@ #!/usr/bin/perl +use FindBin qw($Bin); +use lib "$Bin/../../../../lib/perl"; + use Test::More tests => 18; use DBD; diff --git a/src/tools/test/Device.pl b/src/tools/test/Device.plt similarity index 93% rename from src/tools/test/Device.pl rename to src/tools/test/Device.plt index 0b960d2a5..d362054c2 100644 --- a/src/tools/test/Device.pl +++ b/src/tools/test/Device.plt @@ -1,5 +1,8 @@ #!/usr/bin/perl +use FindBin qw($Bin); +use lib "$Bin/../../../../lib/perl"; + use Test::More tests => 16; use DBD::Device; diff --git a/src/tools/test/Driver.pl b/src/tools/test/Driver.plt similarity index 73% rename from src/tools/test/Driver.pl rename to src/tools/test/Driver.plt index 36f065996..f78c66da9 100644 --- a/src/tools/test/Driver.pl +++ b/src/tools/test/Driver.plt @@ -1,5 +1,8 @@ #!/usr/bin/perl +use FindBin qw($Bin); +use lib "$Bin/../../../../lib/perl"; + use Test::More tests => 2; use DBD::Driver; diff --git a/src/tools/test/Function.pl b/src/tools/test/Function.plt similarity index 74% rename from src/tools/test/Function.pl rename to src/tools/test/Function.plt index 7df69e44f..6eb124fa8 100644 --- a/src/tools/test/Function.pl +++ b/src/tools/test/Function.plt @@ -1,5 +1,8 @@ #!/usr/bin/perl +use FindBin qw($Bin); +use lib "$Bin/../../../../lib/perl"; + use Test::More tests => 2; use DBD::Function; diff --git a/src/tools/test/Makefile b/src/tools/test/Makefile new file mode 100644 index 000000000..b0864e38a --- /dev/null +++ b/src/tools/test/Makefile @@ -0,0 +1,26 @@ +#************************************************************************* +# Copyright (c) 2012 UChicago Argonne LLC, as Operator of Argonne +# National Laboratory. +# EPICS BASE is distributed subject to a Software License Agreement found +# in the file LICENSE that is included with this distribution. +#************************************************************************* +TOP=../../.. + +include $(TOP)/configure/CONFIG + +TESTS += Breaktable +TESTS += DBD +TESTS += Device +TESTS += Driver +TESTS += Function +TESTS += macLib +TESTS += Menu +TESTS += Recfield +TESTS += Recordtype +TESTS += Registrar +TESTS += Variable + +TESTSCRIPTS_HOST += $(TESTS:%=%.t) + +include $(TOP)/configure/RULES + diff --git a/src/tools/test/Menu.pl b/src/tools/test/Menu.plt similarity index 94% rename from src/tools/test/Menu.pl rename to src/tools/test/Menu.plt index dc6db9841..f8da94b97 100644 --- a/src/tools/test/Menu.pl +++ b/src/tools/test/Menu.plt @@ -1,5 +1,8 @@ #!/usr/bin/perl +use FindBin qw($Bin); +use lib "$Bin/../../../../lib/perl"; + use Test::More tests => 14; use DBD::Menu; diff --git a/src/tools/test/Recfield.pl b/src/tools/test/Recfield.plt similarity index 98% rename from src/tools/test/Recfield.pl rename to src/tools/test/Recfield.plt index 45f4e455c..bf92ea83d 100644 --- a/src/tools/test/Recfield.pl +++ b/src/tools/test/Recfield.plt @@ -1,5 +1,8 @@ #!/usr/bin/perl +use FindBin qw($Bin); +use lib "$Bin/../../../../lib/perl"; + use Test::More tests => 76; use DBD::Recfield; diff --git a/src/tools/test/Recordtype.pl b/src/tools/test/Recordtype.plt similarity index 95% rename from src/tools/test/Recordtype.pl rename to src/tools/test/Recordtype.plt index b403ba103..1c829ae49 100644 --- a/src/tools/test/Recordtype.pl +++ b/src/tools/test/Recordtype.plt @@ -1,5 +1,8 @@ #!/usr/bin/perl +use FindBin qw($Bin); +use lib "$Bin/../../../../lib/perl"; + use Test::More tests => 17; use DBD::Recordtype; diff --git a/src/tools/test/Registrar.pl b/src/tools/test/Registrar.plt similarity index 74% rename from src/tools/test/Registrar.pl rename to src/tools/test/Registrar.plt index 326cf0064..2c203c016 100644 --- a/src/tools/test/Registrar.pl +++ b/src/tools/test/Registrar.plt @@ -1,5 +1,8 @@ #!/usr/bin/perl +use FindBin qw($Bin); +use lib "$Bin/../../../../lib/perl"; + use Test::More tests => 2; use DBD::Registrar; diff --git a/src/tools/test/Variable.pl b/src/tools/test/Variable.plt similarity index 84% rename from src/tools/test/Variable.pl rename to src/tools/test/Variable.plt index 84f67b0d8..c8a1a023d 100644 --- a/src/tools/test/Variable.pl +++ b/src/tools/test/Variable.plt @@ -1,5 +1,8 @@ #!/usr/bin/perl +use FindBin qw($Bin); +use lib "$Bin/../../../../lib/perl"; + use Test::More tests => 4; use DBD::Variable; diff --git a/src/tools/test/macLib.pl b/src/tools/test/macLib.plt similarity index 98% rename from src/tools/test/macLib.pl rename to src/tools/test/macLib.plt index e8419baa6..b0c987818 100644 --- a/src/tools/test/macLib.pl +++ b/src/tools/test/macLib.plt @@ -1,7 +1,7 @@ #!/usr/bin/perl use FindBin qw($Bin); -use lib "$Bin/../../../lib/perl"; +use lib "$Bin/../../../../lib/perl"; use Test::More tests => 34; From f1994996adec0655a5b9473c463a1a5d4c4953f7 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Tue, 27 Mar 2012 10:47:59 -0500 Subject: [PATCH 30/32] Convert registerRecordDeviceDriver.pl to use DBD module. The output is now a bit more compact as it uses Text::Wrap on the declarations and array data. --- .../registry/registerRecordDeviceDriver.pl | 295 +++++++++--------- src/tools/DBD/Variable.pm | 25 +- 2 files changed, 164 insertions(+), 156 deletions(-) diff --git a/src/ioc/registry/registerRecordDeviceDriver.pl b/src/ioc/registry/registerRecordDeviceDriver.pl index 3fa64cbe3..3adda373a 100755 --- a/src/ioc/registry/registerRecordDeviceDriver.pl +++ b/src/ioc/registry/registerRecordDeviceDriver.pl @@ -1,7 +1,7 @@ eval 'exec perl -S $0 ${1+"$@"}' # -*- Mode: perl -*- if $running_under_some_shell; # registerRecordDeviceDriver #************************************************************************* -# Copyright (c) 2009 UChicago Argonne LLC, as Operator of Argonne +# Copyright (c) 2012 UChicago Argonne LLC, as Operator of Argonne # National Laboratory. # Copyright (c) 2002 The Regents of the University of California, as # Operator of Los Alamos National Laboratory. @@ -9,52 +9,35 @@ eval 'exec perl -S $0 ${1+"$@"}' # -*- Mode: perl -*- # in file LICENSE that is included with this distribution. #************************************************************************* +use strict; + use FindBin qw($Bin); use lib "$Bin/../../lib/perl"; -use EPICS::Path; -($file, $subname, $bldTop) = @ARGV; -$numberRecordType = 0; -$numberDeviceSupport = 0; -$numberDriverSupport = 0; +use DBD; +use DBD::Parser; +use EPICS::Readfile; +use EPICS::Path; +use Text::Wrap; + +my ($file, $subname, $bldTop) = @ARGV; + +my $dbd = DBD->new(); +&ParseDBD($dbd, &Readfile($file)); + +$Text::Wrap::columns = 75; # Eliminate chars not allowed in C symbol names -$c_bad_ident_chars = '[^0-9A-Za-z_]'; +my $c_bad_ident_chars = '[^0-9A-Za-z_]'; $subname =~ s/$c_bad_ident_chars/_/g; # Process bldTop like convertRelease.pl does $bldTop = LocalPath(UnixPath($bldTop)); $bldTop =~ s/([\\"])/\\\1/g; # escape back-slashes and double-quotes -open(INP,"$file") or die "$! opening file"; -while() { - next if m/ ^ \s* \# /x; - if (m/ \b recordtype \s* \( \s* (\w+) \s* \) /x) { - $recordType[$numberRecordType++] = $1; - } - elsif (m/ \b device \s* \( \s* (\w+) \W+ \w+ \W+ (\w+) /x) { - $deviceRecordType[$numberDeviceSupport] = $1; - $deviceSupport[$numberDeviceSupport] = $2; - $numberDeviceSupport++; - } - elsif (m/ \b driver \s* \( \s* (\w+) \s* \) /x) { - $driverSupport[$numberDriverSupport++] = $1; - } - elsif (m/ \b registrar \s* \( \s* (\w+) \s* \) /x) { - push @registrars, $1; - } - elsif (m/ \b function \s* \( \s* (\w+) \s* \) /x) { - push @registrars, "register_func_$1"; - } - elsif (m/ \b variable \s* \( \s* (\w+) \s* , \s* (\w+) \s* \) /x) { - $varType{$1} = $2; - push @variables, $1; - } -} -close(INP) or die "$! closing file"; +# Start of generated file -# beginning of generated routine print << "END" ; /* THIS IS A GENERATED FILE. DO NOT EDIT! */ /* Generated from $file */ @@ -70,104 +53,115 @@ extern "C" { END -#definitions for recordtype -if($numberRecordType>0) { - for ($i=0; $i<$numberRecordType; $i++) { - print "epicsShareExtern rset *pvar_rset_$recordType[$i]RSET;\n"; - print "epicsShareExtern int (*pvar_func_$recordType[$i]RecordSizeOffset)(dbRecordType *pdbRecordType);\n" +my %rectypes = %{$dbd->recordtypes}; +my @dsets; +if (%rectypes) { + my @rtypnames = sort keys %rectypes; + + # Declare the record support entry tables + print wrap('epicsShareExtern rset ', ' ', + join(', ', map {"*pvar_rset_${_}RSET"} @rtypnames)), ";\n\n"; + + # Declare the RecordSizeOffset functions + print "typedef int (*rso_func)(dbRecordType *pdbRecordType);\n"; + print wrap('epicsShareExtern rso_func ', ' ', + join(', ', map {"pvar_func_${_}RecordSizeOffset"} @rtypnames)), ";\n\n"; + + # List of record type names + print "static const char * const recordTypeNames[] = {\n"; + print wrap(' ', ' ', join(', ', map {"\"$_\""} @rtypnames)); + print "\n};\n\n"; + + # List of pointers to each RSET and RecordSizeOffset function + print "static const recordTypeLocation rtl[] = {\n"; + print join(",\n", map { + " {pvar_rset_${_}RSET, pvar_func_${_}RecordSizeOffset}" + } @rtypnames); + print "\n};\n\n"; + + for my $rtype (@rtypnames) { + my @devices = $rectypes{$rtype}->devices; + for my $dtype (@devices) { + my $dset = $dtype->name; + push @dsets, $dset; + } } - print "\nstatic const char * const recordTypeNames[$numberRecordType] = {\n"; - for ($i=0; $i<$numberRecordType; $i++) { - print " \"$recordType[$i]\""; - if($i < $numberRecordType-1) { print ",";} - print "\n"; + + if (@dsets) { + # Declare the device support entry tables + print wrap('epicsShareExtern dset ', ' ', + join(', ', map {"*pvar_dset_$_"} @dsets)), ";\n\n"; + + # List of dset names + print "static const char * const deviceSupportNames[] = {\n"; + print wrap(' ', ' ', join(', ', map {"\"$_\""} @dsets)); + print "\n};\n\n"; + + # List of pointers to each dset + print "static const dset * const devsl[] = {\n"; + print wrap(' ', ' ', join(", ", map {"pvar_dset_$_"} @dsets)); + print "\n};\n\n"; } +} + +my %drivers = %{$dbd->drivers}; +if (%drivers) { + my @drivers = sort keys %drivers; + + # Declare the driver entry tables + print wrap('epicsShareExtern drvet ', ' ', + join(', ', map {"*pvar_drvet_$_"} @drivers)), ";\n\n"; + + # List of drvet names + print "static const char *driverSupportNames[] = {\n"; + print wrap(' ', ' ', join(', ', map {"\"$_\""} @drivers)); print "};\n\n"; - print "static const recordTypeLocation rtl[$i] = {\n"; - for ($i=0; $i<$numberRecordType; $i++) { - print " {pvar_rset_$recordType[$i]RSET, pvar_func_$recordType[$i]RecordSizeOffset}"; - if($i < $numberRecordType-1) { print ",";} - print "\n"; - } + # List of pointers to each drvet + print "static struct drvet *drvsl[] = {\n"; + print join(",\n", map {" pvar_drvet_$_"} @drivers); print "};\n\n"; } -#definitions for device -if($numberDeviceSupport>0) { - for ($i=0; $i<$numberDeviceSupport; $i++) { - print "epicsShareExtern dset *pvar_dset_$deviceSupport[$i];\n"; - } - print "\nstatic const char * const deviceSupportNames[$numberDeviceSupport] = {\n"; - for ($i=0; $i<$numberDeviceSupport; $i++) { - print " \"$deviceSupport[$i]\""; - if($i < $numberDeviceSupport-1) { print ",";} - print "\n"; - } - print "};\n\n"; - - print "static const dset * const devsl[$i] = {\n"; - for ($i=0; $i<$numberDeviceSupport; $i++) { - print " pvar_dset_$deviceSupport[$i]"; - if($i < $numberDeviceSupport-1) { print ",";} - print "\n"; - } - print "};\n\n"; +my @registrars = sort keys %{$dbd->registrars}; +my @functions = sort keys %{$dbd->functions}; +push @registrars, map {"register_func_$_"} @functions; +if (@registrars) { + # Declare the registrar functions + print "typedef void (*reg_func)(void);\n"; + print wrap('epicsShareExtern reg_func ', ' ', + join(', ', map {"pvar_func_$_"} @registrars)), ";\n\n"; } -#definitions for driver -if($numberDriverSupport>0) { - for ($i=0; $i<$numberDriverSupport; $i++) { - print "epicsShareExtern drvet *pvar_drvet_$driverSupport[$i];\n"; +my %variables = %{$dbd->variables}; +if (%variables) { + my @varnames = sort keys %variables; + + # Declare the variables + for my $var (@varnames) { + my $vtype = $variables{$var}->var_type; + print "epicsShareExtern $vtype * const pvar_${vtype}_$var;\n"; } - print "\nstatic const char *driverSupportNames[$numberDriverSupport] = {\n"; - for ($i=0; $i<$numberDriverSupport; $i++) { - print " \"$driverSupport[$i]\""; - if($i < $numberDriverSupport-1) { print ",";} - print "\n"; + + # Generate the structure for registering variables with iocsh + print "\nstatic struct iocshVarDef vardefs[] = {\n"; + for my $var (@varnames) { + my $vtype = $variables{$var}->var_type; + my $itype = $variables{$var}->iocshArg_type; + print " {\"$var\", $itype, pvar_${vtype}_$var},\n"; } - print "};\n\n"; - - print "static struct drvet *drvsl[$i] = {\n"; - for ($i=0; $i<$numberDriverSupport; $i++) { - print " pvar_drvet_$driverSupport[$i]"; - if($i < $numberDriverSupport-1) { print ",";} - print "\n"; - } - print "};\n\n"; + print " {NULL, iocshArgInt, NULL}\n};\n\n"; } -#definitions registrar -if(@registrars) { - foreach $reg (@registrars) { - print "epicsShareExtern void (*pvar_func_$reg)(void);\n"; - } - print "\n"; -} +# Now for actual registration routine -if (@variables) { - foreach $var (@variables) { - print "epicsShareExtern $varType{$var} *pvar_$varType{$var}_$var;\n"; - } - %iocshTypes = ( - 'int' => 'iocshArgInt', - 'double' => 'iocshArgDouble' - ); - print "static struct iocshVarDef vardefs[] = {\n"; - foreach $var (@variables) { - $argType = $iocshTypes{$varType{$var}}; - die "Unknown variable type $varType{$var} for variable $var" - unless $argType; - print "\t{\"$var\", $argType, (void * const)pvar_$varType{$var}_$var},\n"; - } - print "\t{NULL, iocshArgInt, NULL}\n};\n\n"; -} +print << "END"; +int $subname(DBBASE *pbase) +{ + static int executed = 0; +END -#Now actual registration code. - -print "int $subname(DBBASE *pbase)\n{\n"; - -print << "END" if ($bldTop ne '') ; +print << "END" if $bldTop ne ''; const char *bldTop = "$bldTop"; const char *envTop = getenv("TOP"); @@ -179,57 +173,62 @@ print << "END" if ($bldTop ne '') ; END -print << "END" ; +print << 'END'; if (!pbase) { - printf("pdbbase is NULL; you must load a DBD file first.\\n"); + printf("pdbbase is NULL; you must load a DBD file first.\n"); return -1; } + if (executed) { + printf("Registration already done.\n"); + return 0; + } + executed = 1; + END -if($numberRecordType>0) { - print " registerRecordTypes(pbase, $numberRecordType, ", - "recordTypeNames, rtl);\n"; -} -if($numberDeviceSupport>0) { - print " registerDevices(pbase, $numberDeviceSupport, ", - "deviceSupportNames, devsl);\n"; -} -if($numberDriverSupport>0) { - print " registerDrivers(pbase, $numberDriverSupport, ", - "driverSupportNames, drvsl);\n"; -} -foreach $reg (@registrars) { - print " (*pvar_func_$reg)();\n"; -} +print << 'END' if %rectypes; + registerRecordTypes(pbase, NELEMENTS(rtl), recordTypeNames, rtl); +END -if (@variables) { - print " iocshRegisterVariable(vardefs);\n"; -} -print << "END" ; +print << 'END' if @dsets; + registerDevices(pbase, NELEMENTS(devsl), deviceSupportNames, devsl); +END + +print << 'END' if %drivers; + registerDrivers(pbase, NELEMENTS(drvsl), driverSupportNames, drvsl); +END + +print << "END" for @registrars; + pvar_func_$_(); +END + +print << 'END' if %variables; + iocshRegisterVariable(vardefs); +END + +print << "END"; return 0; } -/* registerRecordDeviceDriver */ -static const iocshArg registerRecordDeviceDriverArg0 = - {"pdbbase",iocshArgPdbbase}; -static const iocshArg *registerRecordDeviceDriverArgs[1] = - {®isterRecordDeviceDriverArg0}; -static const iocshFuncDef registerRecordDeviceDriverFuncDef = - {"$subname",1,registerRecordDeviceDriverArgs}; -static void registerRecordDeviceDriverCallFunc(const iocshArgBuf *) +/* $subname */ +static const iocshArg rrddArg0 = {"pdbbase", iocshArgPdbbase}; +static const iocshArg *rrddArgs[] = {&rrddArg0}; +static const iocshFuncDef rrddFuncDef = + {"$subname", 1, rrddArgs}; +static void rrddCallFunc(const iocshArgBuf *) { $subname(*iocshPpdbbase); } } // extern "C" + /* * Register commands on application startup */ static int Registration() { iocshRegisterCommon(); - iocshRegister(®isterRecordDeviceDriverFuncDef, - registerRecordDeviceDriverCallFunc); + iocshRegister(&rrddFuncDef, rrddCallFunc); return 0; } diff --git a/src/tools/DBD/Variable.pm b/src/tools/DBD/Variable.pm index 11f5a2c05..8d02d64cd 100644 --- a/src/tools/DBD/Variable.pm +++ b/src/tools/DBD/Variable.pm @@ -2,26 +2,35 @@ package DBD::Variable; use DBD::Base; @ISA = qw(DBD::Base); -my %var_types = ("int" => 1, "double" => 1); +my %valid_types = ( + # C type name => corresponding iocshArg type identifier + int => 'iocshArgInt', + double => 'iocshArgDouble' +); sub init { my ($this, $name, $type) = @_; if (defined $type) { - unquote $type; + unquote $type; } else { - $type = "int"; + $type = "int"; } - exists $var_types{$type} or - dieContext("Unknown variable type '$type', valid types are:", - sort keys %var_types); + exists $valid_types{$type} or + dieContext("Unknown variable type '$type', valid types are:", + sort keys %valid_types); $this->SUPER::init($name, "variable name"); $this->{VAR_TYPE} = $type; return $this; } sub var_type { - my $this = shift; - return $this->{VAR_TYPE}; + my $this = shift; + return $this->{VAR_TYPE}; +} + +sub iocshArg_type { + my $this = shift; + return $valid_types{$this->{VAR_TYPE}}; } 1; From 4e6e9518a3834c5763f66c9519c18d3c08ca7989 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Wed, 28 Mar 2012 17:54:50 -0500 Subject: [PATCH 31/32] Use the new DBD processing scripts to generate dependency files. --- configure/RULES.Db | 34 +++++++++++++++++----------------- src/ioc/db/RULES | 10 ++++------ 2 files changed, 21 insertions(+), 23 deletions(-) diff --git a/configure/RULES.Db b/configure/RULES.Db index 4152beaa0..8bc67b136 100644 --- a/configure/RULES.Db +++ b/configure/RULES.Db @@ -227,31 +227,31 @@ $(INSTALL_DB)/%.template: %.template $(COMMON_DIR)/%Record.h: $(COMMON_DIR)/%Record.dbd @$(RM) $(notdir $@)$(DEP) - @$(DBDDEPENDS_CMD) - $(ECHO) "$<:../Makefile" >> $(notdir $@)$(DEP) + @$(DBTORECORDTYPEH) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP) + @echo "$@: ../Makefile" >> $(notdir $@)$(DEP) @$(RM) $@ - $(DBTORECORDTYPEH) $(DBDFLAGS) $< $@ + $(DBTORECORDTYPEH) $(DBDFLAGS) -o $@ $< $(COMMON_DIR)/%Record.h: %Record.dbd @$(RM) $(notdir $@)$(DEP) - @$(DBDDEPENDS_CMD) - $(ECHO) "$<:../Makefile" >> $(notdir $@)$(DEP) + @$(DBTORECORDTYPEH) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP) + @echo "$@: ../Makefile" >> $(notdir $@)$(DEP) @$(RM) $@ - $(DBTORECORDTYPEH) $(DBDFLAGS) $< $@ + $(DBTORECORDTYPEH) $(DBDFLAGS) -o $@ $< $(COMMON_DIR)/menu%.h: $(COMMON_DIR)/menu%.dbd @$(RM) $(notdir $@)$(DEP) - @$(DBDDEPENDS_CMD) - $(ECHO) "$<:../Makefile" >> $(notdir $@)$(DEP) + @$(DBTOMENUH) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP) + @echo "$@: ../Makefile" >> $(notdir $@)$(DEP) @$(RM) $@ - $(DBTOMENUH) $(DBDFLAGS) $< $@ + $(DBTOMENUH) $(DBDFLAGS) -o $@ $< $(COMMON_DIR)/menu%.h: menu%.dbd @$(RM) $(notdir $@)$(DEP) - @$(DBDDEPENDS_CMD) - $(ECHO) "$<:../Makefile" >> $(notdir $@)$(DEP) + @$(DBTOMENUH) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP) + @echo "$@: ../Makefile" >> $(notdir $@)$(DEP) @$(RM) $@ - $(DBTOMENUH) $(DBDFLAGS) $< $@ + $(DBTOMENUH) $(DBDFLAGS) -o $@ $< .PRECIOUS: $(COMMON_DIR)/%.h @@ -261,18 +261,18 @@ $(COMMON_DIR)/bpt%.dbd: bpt%.data @$(RM) $@ $(MAKEBPT) $< $@ -$(COMMON_DIR)/%.dbd: $(COMMON_DIR)/%Include.dbd +$(COMMON_DIR)/%.dbd: $(COMMON_DIR)/%Include.dbd @$(RM) $(notdir $@)$(DEP) - @$(DBDDEPENDS_CMD) - $(ECHO) "$<:../Makefile" >> $(notdir $@)$(DEP) + @$(DBEXPAND) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP) + @echo "$@: ../Makefile" >> $(notdir $@)$(DEP) $(ECHO) "Expanding dbd" @$(RM) $@ $(DBEXPAND) $(DBDFLAGS) -o $@ $< $(COMMON_DIR)/%.dbd: %Include.dbd @$(RM) $(notdir $@)$(DEP) - @$(DBDDEPENDS_CMD) - $(ECHO) "$<:../Makefile" >> $(notdir $@)$(DEP) + @$(DBEXPAND) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP) + @echo "$@: ../Makefile" >> $(notdir $@)$(DEP) $(ECHO) "Expanding dbd" @$(RM) $@ $(DBEXPAND) $(DBDFLAGS) -o $@ $< diff --git a/src/ioc/db/RULES b/src/ioc/db/RULES index 7ba979e70..a3dd07621 100644 --- a/src/ioc/db/RULES +++ b/src/ioc/db/RULES @@ -13,10 +13,8 @@ $(filter-out $(STATIC_SRCS),$(dbCore_SRCS)) : $(COMMON_DIR)/dbCommon.h -dbCommon.h$(DEP): $(IOCDIR)/db/dbCommonRecord.dbd $(IOCDIR)/db/dbCommon.dbd - @$(RM) $@ - @-$(MKMF) -m $@ ../db $(COMMON_DIR)/dbCommon.h $< - -$(COMMON_DIR)/dbCommon.h: $(IOCDIR)/db/dbCommonRecord.dbd $(IOCDIR)/db/dbCommon.dbd +$(COMMON_DIR)/dbCommon.h: $(IOCDIR)/db/dbCommonRecord.dbd + @$(RM) $(notdir $@)$(DEP) + @$(DBTORECORDTYPEH) -D -I ../db -o $@ $< > $(notdir $@)$(DEP) $(RM) $@ - $(DBTORECORDTYPEH) -I ../db $< $@ + $(DBTORECORDTYPEH) -I ../db -o $@ $< From 9ec0cff0e5225b05fc24909c06e648b8297b0e57 Mon Sep 17 00:00:00 2001 From: Andrew Johnson Date: Mon, 2 Apr 2012 15:34:23 -0500 Subject: [PATCH 32/32] configure: Clean up some other DBDEPENDS stuff --- configure/RULES.Db | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/configure/RULES.Db b/configure/RULES.Db index 8bc67b136..9f68f0bb7 100644 --- a/configure/RULES.Db +++ b/configure/RULES.Db @@ -113,9 +113,6 @@ DBDDEPENDS_FILES += $(addsuffix $(DEP),$(HINC) \ $(patsubst $(COMMON_DIR)/%,%,$(COMMON_DBS)) \ $(patsubst $(COMMON_DIR)/%,%,$(COMMON_DBDS))) -DBDDEPENDS_FLAGS = $(subst -I,,$(filter-out -S%,$(DBDFLAGS))) -DBDDEPENDS_CMD = -$(MKMF) -m $(notdir $@)$(DEP) $(DBDDEPENDS_FLAGS) $@ $< - MAKEDBDEPENDS = $(PERL) $(TOOLS)/makeDbDepends.pl ##################################################### @@ -307,8 +304,8 @@ $(COMMON_DIR)/%.db$(RAW): $(COMMON_DIR)/%.edf $(COMMON_DIR)/%.db$(RAW): %.substitutions @$(RM) $(notdir $@)$(DEP) - $(MAKEDBDEPENDS) $@ $< $(TEMPLATE_FILENAME) >> $(notdir $@)$(DEP) - $(ECHO) "$@:$(TEMPLATE_FILENAME)" >> $(notdir $@)$(DEP) + $(MAKEDBDEPENDS) $@ $< $(TEMPLATE_FILENAME) > $(notdir $@)$(DEP) + @echo "$@: $(TEMPLATE_FILENAME)" >> $(notdir $@)$(DEP) $(ECHO) "Inflating database from $< $(TEMPLATE_FILENAME)" @$(RM) $@ $*.tmp $(MSI) $(DBFLAGS) -S$< $(TEMPLATE_FILENAME) > $*.tmp @@ -316,7 +313,7 @@ $(COMMON_DIR)/%.db$(RAW): %.substitutions $(COMMON_DIR)/%.db$(RAW): %.template @$(RM) $(notdir $@)$(DEP) - @$(MAKEDBDEPENDS) $@ $^ >> $(notdir $@)$(DEP) + @$(MAKEDBDEPENDS) $@ $< > $(notdir $@)$(DEP) $(ECHO) "Inflating database from $<" @$(RM) $@ $*.tmp $(MSI) $(DBFLAGS) $< > $*.tmp