2004-04-29: work in progress
This commit is contained in:
Andrew Johnson
@@ -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;
|
||||
@@ -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;
|
||||
@@ -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, <FILE>;
|
||||
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;
|
||||
Executable
+34
@@ -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;
|
||||
}
|
||||
Executable
+52
@@ -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";
|
||||
}
|
||||
Executable
+42
@@ -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{$_};
|
||||
}
|
||||
}
|
||||
Reference in New Issue
Block a user