pa.configgen.6.151.17.source-code.make-config-preproc.pl Maven / Gradle / Ivy
Go to download
Show more of this group Show more artifacts with this name
Show all versions of configgen Show documentation
Show all versions of configgen Show documentation
Config java code generation from defintion files for Java Vespa components.
#!/usr/bin/perl
# Copyright 2017 Yahoo Holdings. Licensed under the terms of the Apache 2.0 license. See LICENSE in the project root.
# This is the config pre-processor.
# It handles import statements, and does syntax checking etc.
# The idea is that it will be called directly from the script
# that does the code generation.
#
# Errors and warnings are printed in "next-error" compatible ways
# for emacs etc.
#
# Indented like this:
# (cperl-set-style "Whitesmith")
# (setq cperl-continued-brace-offset -4)
require 5.006_001;
use strict;
use warnings;
use Digest::MD5;
use Math::BigInt;
use Math::BigFloat;
die "Usage: $0 " unless $#ARGV == 0;
my $defname = $ARGV[0];
my $md5 = Digest::MD5->new;
my @c_keywords =
("asm", "auto", "bool", "break", "case", "catch",
"char", "class", "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", "operator",
"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", "and", "bitor",
"not", "or", "xor", "and_eq", "compl", "not_eq", "or_eq", "xor_eq",
"bitand");
my @java_keywords =
("abstract", "boolean", "break", "byte", "case",
"catch", "char", "class","continue", "default", "do", "double",
"else", "extends","false", "final", "finally", "float", "for",
"if","implements", "import", "instanceof", "int", "interface",
"long","native", "new", "null", "package", "private",
"protected","public", "return", "short", "static",
"strictfp","super","switch", "synchronized", "this",
"throw","throws","transient", "true", "try", "void",
"volatile","while", "byvalue", "cast", "const", "future",
"generic","goto", "inner", "operator", "outer", "rest", "var");
my %reserved_words;
foreach my $word (@c_keywords) {
$reserved_words{$word} = "C";
}
foreach my $word (@java_keywords) {
my $x = $reserved_words{$word};
if (defined($x)) {
$x = "$x, Java";
} else {
$x = "Java";
}
$reserved_words{$word} = $x;
}
my $MIN_INT = -0x80000000;
my $MAX_INT = 0x7fffffff;
my $MIN_DOUBLE = -1e308;
my $MAX_DOUBLE = 1e308;
sub do_file {
my ($file, $prefix, $strip) = @_;
local *FH;
open FH, "< $file" or die "Cannot open $file: $!\n";
local *COPY;
my $dir = $ENV{"VESPA_CONFIG_DEF_DIR"};
my $copy;
my $file_version;
if (defined($dir)) {
$copy = $file;
$copy =~ s=.*/==;
$copy = "$dir/$copy";
open COPY, ">$copy.new" or die "Cannot open file $copy.new: $!\n";
}
# Read line by line.
# 1. Strip away comments and trailing blanks
# 2. Report any errors
# 3. Handle import statements, disallow multi-level imports
# 4. Print everyting to stdout
my $linenr = 0;
my $written_lines = 0;
my $quoted_strip = quotemeta($strip);
my $seen_version = 0;
while () {
print COPY $_ if $copy;
++$linenr;
my $line = $_;
chomp $line;
# Don't process comments or add them to md5 checksum, but print them
# such that codegen can include comments
if ($line =~ /^\s*#/) {
print "$line\n";
next;
}
# Strip away comments that are not at start of line
$line = &strip_trailing_comment($line, $linenr)
if ($line =~ m=[\\\#]=);
if ($line eq "::error::") {
return -1;
}
# Skip lines that are only whitespace
next if $line =~ m=^\s*$=;
# Get rid of trailing whitespace
$line =~ s=\s+$==;
if (!$seen_version) {
if ($line =~ m!^version=([a-zA-Z0-9][-a-zA-Z0-9_/?]*)!) {
$file_version = $1;
$seen_version = 1;
if ($prefix) {
print "$prefix imported $file";
print ":$strip" if $strip;
print " ";
}
print "$line\n";
next;
} else {
print STDERR "$file:$linenr: error: Definition file does not "
. "start with a valid version= identifier!\n";
return -1;
}
}
if ($strip) {
next unless $line =~ m=^${quoted_strip}[. \t]=;
}
if (&check_syntax($line, $linenr, $file) == -1) {
return -1;
}
# Handle import statements
my ($name, $type, $remains, $junk) = split(/\s+/, $line, 4);
if ($type eq "import") {
if ($strip || $prefix) {
my $col = index($line, $type, length("$name "));
print STDERR "$file:$linenr:$col: error: Multi-level "
. "imports are disallowed.\n";
return -1;
}
if ($junk) {
my $col = index($line, $junk, length("$name $type $remains"))
+ 1;
print STDERR "$file:$linenr:$col: error: Junk after import "
. "target \"$remains\": \"$junk\"\n";
return -1;
}
my ($impfile, $var) = split(/:/, $remains, 2);
$var = "" unless $var; # Make it defined.
# Make sure only arrays can include arrays:
if ($name =~ m=\[\]$= && (!$var || $var !~ m=\[\]$=)) {
print STDERR "$file:$linenr: error: Array cannot import "
. "non-array in: $line\n";
return -1;
} elsif ($name !~ m=\[\]$= && ($var && $var =~ m=\[\]$=)) {
print STDERR "$file:$linenr: error: Non-array cannot import "
. "array in: $line\n";
return -1;
}
local *X;
unless (open(X, "< $impfile")) {
my $col = index($line, $remains, length("$name $type")) + 1;
print STDERR "$file:$linenr:$col: error: Cannot open "
. "\"$impfile\": $!\n";
return -1;
}
close X;
my $imported_lines = &do_file("$impfile", "$name", "$var");
if ($imported_lines == -1) {
my $col = index($line, $remains, length("$name $type")) + 1;
print STDERR "$file:$linenr:$col: error: Imported from here "
. "as: $line\n";
return -1;
} elsif ($imported_lines == 0) {
my $col = index($line, $remains, length("$name $type")) + 1;
print STDERR "$file:$linenr:$col: error: Import target "
. "\"$var\" not found in \"$impfile\"\n";
return -1;
}
$written_lines += $imported_lines;
} else {
++$written_lines;
if ($strip) {
$line =~ s=^${quoted_strip}=${prefix}=
} elsif ($prefix) {
$line = $prefix . "." . $line;
}
if (&check_name_sanity($line, $linenr, $file) == -1
|| &check_enum_sanity($line, $linenr, $file) == -1) {
return -1;
}
$line = &normalize_line($line, $linenr);
if ($line eq "::error::") {
return -1;
}
print $line . "\n";
}
# Add this line to the md5 checksum
$md5->add("$line\n") unless $prefix;
}
print "md5=" . $md5->hexdigest . "\n" unless $prefix;
close FH;
if ($copy) {
close COPY;
# We have made a copy. It needs a new name..
my $new_name = $copy;
$new_name =~ s=\.def==;
$new_name .= ".${file_version}.def";
if (-f $new_name) {
system "cmp $copy.new $new_name 2>/dev/null" and die "$file:1: error: Definition file $file differs from ${new_name}!\n";
unlink("$copy.new");
} else {
rename("$copy.new", "$new_name") or die "Rename $copy.new -> $new_name failed: $!\n";
}
}
return $written_lines;
}
sub normalize_enum {
my($x, $linenr, $colnr) = @_;
my $len = length($x);
my $char = '';
my $output = '{ ';
my $index;
my %enum = ();
my $current_variable = '';
for ($index = $colnr + 1; $index < $len; ++$index) {
$char = substr($x, $index, 1);
if ($char eq '}') {
if (length($current_variable) < 2) {
print STDERR "$defname:$linenr:$index: error: ".
" variable must be at least two characters: $x\n" ;
return ('', 0);
} elsif ($enum{$current_variable}) {
print STDERR "$defname:$linenr:$index: error: ".
" enum variable declared twice: $x\n" ;
return ('', 0);
} elsif (!%enum && !$current_variable) {
print STDERR "$defname:$linenr:$index: error: ".
" enum cannot be empty: $x\n" ;
return ('', 0);
}
return ($output.$current_variable." } ", $index);
} elsif ($char eq ',') {
if (length($current_variable) < 2) {
print STDERR "$defname:$linenr:$index: error: ".
" variable must be at least two characters: $x\n" ;
return ('', 0);
} elsif ($enum{$current_variable}) {
print STDERR "$defname:$linenr:$index: error: ".
" enum variable declared twice: $x\n" ;
return ('', 0);
}
$enum{$current_variable} = 1;
$output .= "$current_variable, ";
$current_variable = '';
} elsif ($char =~ m=[A-Z]=) {
$current_variable .= $char;
} elsif ($char =~ m=[0-9_]= && $current_variable) {
$current_variable .= $char;
} elsif ($char =~ m=\s=) {
if ($current_variable && !($x =~ /^.{$index}\s*[,\}]/)) {
print STDERR "$defname:$linenr:$index: error: ".
"expected ',' or '}': $x\n" ;
return ("", 0);
} else {
# skip whitespace
}
} else {
print STDERR "<$char> <$current_variable>\n";
print STDERR "$defname:$linenr:$index: error: ".
"Enum must match [A-Z][A-Z0-9_]+: $x\n";
}
}
return ($output, $index);
}
{ package Range;
$Range::DOUBLE_RANGE =
new Range("a double range=[$MIN_DOUBLE,$MAX_DOUBLE] ",0,14);
$Range::INT_RANGE = new Range("a int range=[$MIN_INT,$MAX_INT] ",0,11);
sub in_range {
my($self, $value) = @_;
if ($value =~ s/KB$//) {
$value *= 1024;
} elsif ($value =~ s/MB$//) {
$value *= (1024 * 1024);
} elsif ($value =~ s/GB$//) {
$value *= (1024*1024*1024);
} elsif ($value =~ s/k$//) {
$value *= 1000;
} elsif ($value =~ s/M$//) {
$value *= 1_000_000;
} elsif ($value =~ s/G$//) {
$value *= 1_000_000_000;
} elsif ($value =~ m=^0[xX]=) {
$value = hex($value);
}
if ($self->{start_bracket} eq '(' ) {
return 0 if $value <= $self->{min};
} elsif ($self->{start_bracket} eq '[' ) {
return 0 if $value < $self->{min};
} else {
print STDERR "Illegal start_bracket '$self->{start_bracket}'\n";
return undef;
}
if ($self->{end_bracket} eq ')' ) {
return 0 if $value >= $self->{max};
} elsif ($self->{end_bracket} eq ']' ) {
return 0 if $value > $self->{max};
} else {
print STDERR "Illegal end_bracket '$self->{start_bracket}'\n";
return undef;
}
return 1;
}
sub new {
my($class, $x, $linenr, $colnr) = @_;
my $len = length($x);
my $self = {};
bless($self, $class);
$self->{min_value} = '';
my $index;
for ($index = $colnr + 1; $index < $len; ++$index) {
my $char = substr($x, $index, 1);
if (($char eq '(' || $char eq '[') && !$self->{start_bracket}) {
$self->{start_bracket} = $char;
} elsif (($char eq ')' || $char eq ']') && !$self->{end_bracket}) {
$self->{end_bracket} = $char;
last;
} elsif ($char =~ m=\s=) {
#ignore whitespace
} elsif ($char eq ',' && !defined($self->{max_value})) {
$self->{max_value} = '';
} elsif ($char =~ m=[\d\.\+eE-]= ) {
(defined($self->{max_value})
? $self->{max_value} : $self->{min_value}) .= $char;
} else {
print STDERR "$defname:$linenr:$index: error: ".
" syntax error: $x\n" ;
return undef;
}
}
if ($self->{min_value} eq '' && $self->{max_value} eq '') {
print STDERR "$defname:$linenr:$colnr: error: ".
" range cannot be unbounded in both ends: $x\n" ;
return undef;
}
unless ($self->{start_bracket} && $self->{end_bracket}) {
print STDERR "$defname:$linenr:$colnr: error: ".
" missing bracket: $x\n" ;
return undef;
}
my @arr = split(/\s+/, $x, 3);
if ($arr[1] eq 'int') {
$self->{min} = Math::BigInt->new
($self->{min_value} eq '' ? $MIN_INT : $self->{min_value});
unless (defined($self->{min}) && $self->{min} ne 'NaN') {
print STDERR "$defname:$linenr:$colnr: error: ".
" parse error $self->{min_value}: $x\n" ;
return undef;
}
my $min_val =
$self->{min} + ($self->{start_bracket} eq '('? 1 : 0);
$self->{max} = Math::BigInt->new
($self->{max_value} eq '' ? $MAX_INT : $self->{max_value});
unless (defined($self->{max}) && $self->{max} ne 'NaN') {
print STDERR "$defname:$linenr:$colnr: error: ".
" parse error $self->{max_value}: $x\n" ;
return undef;
}
my $max_val =
$self->{max} - ($self->{end_bracket} eq ')'? 1 : 0);
if ($min_val < $MIN_INT ) {
print STDERR "$defname:$linenr:$colnr: error: ".
" start of interval less than MIN_INT: $x\n" ;
return undef;
}
if ($max_val > $MAX_INT) {
print STDERR "$self->{max} - 1 > $MAX_INT\n";
print STDERR "$defname:$linenr:$colnr: error: ".
" end of interval greater than MAX_INT: $x\n" ;
return undef;
}
if ($max_val < $min_val) {
print STDERR "$defname:$linenr:$colnr: error: ".
" illegal range: $x\n" ;
return undef;
}
$self->{string} =
"$self->{start_bracket}$self->{min},$self->{max}$self->{end_bracket}";
$self->{string} =~ s/\+//g;
$self->{index} = $index;
return $self;
} elsif ($arr[1] eq 'double') {
$self->{min} = Math::BigFloat->new
($self->{min_value} eq '' ? $MIN_DOUBLE : $self->{min_value});
unless (defined($self->{min}) && $self->{min} ne 'NaN') {
print STDERR "$defname:$linenr:$colnr: error: ".
" parse error $self->{min_value}: $x\n" ;
return undef;
}
$self->{max} = Math::BigFloat->new
($self->{max_value} eq '' ? $MAX_DOUBLE : $self->{max_value});
unless (defined($self->{max}) && $self->{max} ne 'NaN') {
print STDERR "$defname:$linenr:$colnr: error: ".
" parse error $self->{max_value}: $x\n" ;
return undef;
}
if ($self->{min} < $MIN_DOUBLE) {
print STDERR "$defname:$linenr:$colnr: error: ".
" start of interval less than MIN_DOUBLE: $x\n" ;
return undef;
}
if ($self->{max} > $MAX_DOUBLE) {
print STDERR "$defname:$linenr:$colnr: error: ".
" start of interval greater than MAX_DOUBLE: $x\n" ;
return undef;
}
if ($self->{max} < $self->{min}) {
print STDERR "$defname:$linenr:$colnr: error: ".
" illegal range: $x\n" ;
return undef;
}
if (($self->{start_bracket} eq '(' || $self->{end_bracket} eq ')')
&& ($self->{min_value} + $self->{min_value}
>= $self->{min_value} + $self->{max_value})
&& ($self->{max_value} + $self->{max_value}
<= $self->{min_value} + $self->{max_value})) {
print STDERR "$defname:$linenr:$colnr: error: ".
" illegal range: $x\n" ;
return undef;
}
$self->{string} = $self->{start_bracket}.$self->{min}->fnorm.
','.$self->{max}->fnorm.$self->{end_bracket};
$self->{string} =~ s/\+//g;
$self->{index} = $index;
return $self;
} else {
print STDERR "$defname:$linenr:$colnr: error: ".
" range-option works only for type 'int' and 'double': $x\n" ;
return undef;
}
print STDERR "$defname:$linenr:$colnr: error: ".
" script error: $x\n" ;
return undef;
}
}
sub strip_trailing_comment {
my ($x, $linenr) = @_;
my $index = 0;
my $len = length($x);
my $in_quotes = 0;
# ### Support both " and ' quotes maybe?
for ($index = 0; $index < $len; ++$index) {
if (substr($x, $index, 1) eq "\\") {
++$index;
next;
}
if (substr($x, $index, 1) eq "\"") {
$in_quotes ^= 1;
}
if ($in_quotes == 0 && substr($x, $index, 1) eq "#") {
if (!(substr($x, $index - 1, 1) =~ m=\s=)) {
my $col = $index + 1;
print STDERR "$defname:$linenr:$col: warning: No whitespace "
. "before comment in line: $x\n";
}
print substr($x, $index). "\n";
$x = substr($x, 0, $index);
last;
}
}
if ($index > $len) {
print STDERR "$defname:$linenr:$len: error: syntax error, line "
. "ends with \\: \"$x\"\n";
return "::error::";
}
return $x;
}
sub normalize_line {
my ($x, $linenr) = @_;
my $index = 0;
my $len = length($x);
my $in_quotes = 0;
my $char = '';
my $output = '';
my %hash = ();
my @arr = split(/\s+/, $x, 3);
$hash{type} = $arr[1];
for ($index = 0; $index < length($x); ++$index) {
$char = substr($x, $index, 1);
if ($char eq "\\") {
$output .= substr($x, $index, 2);
++$index;
next;
}
if ($char eq "\"") {
$in_quotes ^= 1;
$output .= $char;
next;
}
my $ends_with_whitespace = ($output =~ m= $=);
if ($in_quotes == 0) {
if ($char =~ m=\s=) {
#delete multiple spaces
if (!$ends_with_whitespace) { # && ($output =~ !m=\=$=)) {
$output .= ' ';
}
} elsif ($char eq '{') {
my($enum, $i) = &normalize_enum($x, $linenr, $index);
return "::error::" unless $i;
$index = $i;
$output .= ($ends_with_whitespace) ? $enum : " $enum ";
} elsif ($char eq ',') {
chop $output if ($ends_with_whitespace);
$output .= ',';
} elsif ($char eq '=') {
chop $output if ($ends_with_whitespace);
$output .= '=';
if ($output =~ /range=$/) {
$hash{range} =
new Range($x, $linenr, $index);
return "::error::" unless $hash{range};
$index = $hash{range}->{index};
$output .= $hash{range}->{string}." ";
}
if ($output =~ /default=$/
&& ($hash{type} eq 'int' || $hash{type} eq 'double')) {
$x =~ /^.{$index}=\s*(\S+)/;
$hash{default} = $1;
if ($hash{type} eq 'int' &&
!$Range::INT_RANGE->in_range($hash{default})) {
print STDERR "$defname:$linenr:$index: error: ".
"Default not in range: $x\n";
return "::error::";
}
if ($hash{type} eq 'double' &&
!$Range::DOUBLE_RANGE->in_range($hash{default})) {
print STDERR "$defname:$linenr:$index: error: ".
"Default not in range: $x\n";
return "::error::";
}
}
if (defined($hash{default}) && $hash{range}) {
unless ($hash{range}->in_range($hash{default})) {
print STDERR "$defname:$linenr:$index: error: ".
"Default not in range: $x\n";
return "::error::";
}
}
} else {
$output .= $char;
}
} else {
$output .= $char;
}
}
if ($index > $len) {
print STDERR "$defname:$linenr:$len: error: syntax error, line "
. "ends with \\: \"$x\"\n";
return "::error::";
}
chop $output if $output =~ m/ $/;
return $output;
}
my %used_enum;
sub check_enum_sanity {
my ($line, $linenr, $file) = @_;
my ($name, $type, $rest) = split(/\s+/, $line, 3);
return 0 unless ($type eq "enum");
$name =~ /(.*)\./;
my $prefix = $1;
$prefix = "" unless defined $prefix; # Make top level prefix
$used_enum{"$prefix"} = $used_enum{"$prefix"} || {};
$rest = "" unless defined $rest;
$rest =~ /\{\s*(.*?)\}/;
my @values = split(/[,\s]+/, $1);
foreach my $value (@values) {
if ($used_enum{"$prefix"}->{$value}) {
print STDERR
"$file:$linenr: error: Name \"$value\" is already defined\n";
my $prevdef = $used_enum{"$prefix"}->{$value};
print STDERR "$prevdef: error: At this point\n";
return -1;
} else {
$used_enum{"$prefix"}->{$value} = "$file:$linenr";
}
}
return 0;
}
my %used_name;
my %used_component;
my %banned_prefixes;
my $cns_prev_name;
sub check_name_sanity {
my ($line, $linenr, $file) = @_;
my ($name, $junk) = split(/\s+/, $line, 2);
my $plain_name = $name;
$plain_name =~ s=\[\]$==;
# See if the name is already used.
if ($used_name{"$plain_name"}) {
print STDERR
"$file:$linenr: error: Name \"$name\" is already defined\n";
my $prevdef = $used_name{$name};
print STDERR "$prevdef: error: At this point\n";
return -1;
} else {
$used_name{$name} = "$file:$linenr";
}
# Test for bans
my $banned = "${name}.";
do {
my $err = $banned_prefixes{$banned};
if (defined($err)) {
print STDERR "$file:$linenr: error: The prefix \"$banned\" is illegal here\n";
print STDERR "$err\n";
return -1;
}
} while (($banned =~ s=[.][^.]+[.]$=.=));
# Add any new bans generated by this line
$banned_prefixes{"${name}."} = "$file:$linenr: error: \"${name}\" cannot "
. "be both a struct and a non-struct!";
if ($cns_prev_name) {
my $prev = $cns_prev_name;
my $oldprev = $prev;
while (($prev =~ s=[.][^.]+[.]?$=.=)) {
if (substr($name, 0, length($prev)) eq $prev) {
$banned_prefixes{"$oldprev"} = "$file:" . ($linenr - 1)
. ": error: Last possible line is after this";
last;
}
$oldprev = $prev;
}
}
$cns_prev_name = $name;
# See if any of the components previously have a different "arrayness"
my $part_name = $name;
while (($part_name =~ s=[.][^.]+$==)) {
my $clashing_name = $part_name;
if ($part_name =~ m=\[\]$=) {
$clashing_name =~ s=\[\]$==;
} else {
$clashing_name .= "[]";
}
my $clashline = $used_component{"$clashing_name"};
if (defined $clashline) {
print STDERR "$file:$linenr: error: \"$clashing_name\" cannot be both array and non-array\n";
print STDERR "$clashline: error: Previously defined here\n";
return -1;
} elsif (!$used_component{"$part_name"}) {
$used_component{"$part_name"} = "$file:$linenr";
}
}
return 0;
}
# These are all the allowed types/commands
my %types = ( "int" => \&check_int,
"double" => \&check_double,
"string" => \&check_string,
"reference" => \&check_reference,
"enum" => \&check_enum,
"bool" => \&check_bool,
"properties" => \&check_properties,
"import" => \&check_import );
sub check_syntax {
my ($line, $linenr, $file) = @_;
my $col = 0;
my $llen = length($line);
# Step 1. Sanity check the name.
my $atstart = 1;
my $array_ok = 1;
for ($col = 0; $col < $llen; ++$col) {
my $c = substr($line, $col, 1);
if ($atstart) {
if ($c !~ m=[a-zA-Z]=) {
print STDERR "$file:$linenr:$col: error: Non-alphabetic start "
. "of variable name in $line\n";
return -1;
}
$atstart = 0;
} else {
if ($c =~ m=[a-zA-Z0-9_]=) {
0; # Do nothing
} elsif ($c eq ".") {
$atstart = 1;
$array_ok = 1;
} elsif ($c eq "[") {
if (!$array_ok) {
++$col;
print STDERR "$file:$linenr:$col: error: Arrays cannot be "
. "multidimensional in $line\n";
return -1;
}
++$col;
$array_ok = 0;
$c = substr($line, $col, 1);
if ($c ne "]") {
++$col;
print STDERR "$file:$linenr:$col: error: Expected ] to "
. "terminate array definition in $line\n";
return -1;
}
} elsif ($c =~ m=\s=) {
last;
} else {
++$col;
print STDERR "$file:$linenr:$col: error: Syntax error, "
. "unexpected character in $line\n";
return -1;
}
}
}
my $name = substr($line, 0, $col);
$name =~ s=.*[.]==;
$name =~ s=[[]]$==;
my $clash = $reserved_words{$name};
if ($clash) {
$col -= (3 + length($name));
$col = index($line, $name, $col) + 1;
print STDERR "$file:$linenr:$col: error: $name is a reserved word in: "
. "${clash}\n";
return -1;
}
while (substr($line, $col, 1) =~ m=\s=) {
++$col;
}
# At this point the name is sane. Next, check the type.
my ($type) = split(/\s/, substr($line, $col));
unless (defined $types{$type}) {
++$col;
print STDERR "$file:$linenr:$col: error: Unknown type/command "
. "\"$type\"\n";
return -1;
}
$col += length($type);
while (substr($line, $col, 1) =~ m=\s=) {
++$col;
}
return $types{$type}($col, $line, $linenr, $file);
}
sub reg_words_check {
my ($col, $line, $linenr, $file, $reg) = @_;
my $remainder = substr($line, $col);
my @options = split(/\s+/, $remainder);
foreach my $option (@options) {
# Keep track of where we are for error reporting
$col = index($line, $option, $col) + 1;
unless ($option =~ m!${reg}!) {
print STDERR "$file:$linenr:$col: error: Bad option \"$option\" no match for m!${reg}!\n";
return -1;
}
}
return 0;
}
sub check_int {
my ($col, $line, $linenr, $file) = @_;
my $num = "(-?\\d+(KB|MB|GB|k|M|G)?|0x[0-9a-fA-F]+)"; # All legal numbers
my $optnum = "(${num})?"; # All legal optional numbers
return ®_words_check($col, $line, $linenr, $file,
"^("
. "default=${num}"
. "|range=[[(]${optnum},${optnum}"."[])]"
. "|restart"
. ")\$");
}
sub check_double {
my ($col, $line, $linenr, $file) = @_;
my $num = "-?(\\d+(\\.\\d*)?|\\.\\d+)([eE][+-]?\\d+)?"; # All legal doubles
my $optnum = "(${num})?"; # Optional doubles
return ®_words_check($col, $line, $linenr, $file,
"^("
. "default=${num}"
. "|range=[[(]${optnum},${optnum}"."[])]"
. "|restart"
. ")\$");
}
sub check_string {
my ($col, $line, $linenr, $file) = @_;
my $opts = substr($line, $col);
# not entirely correct either for something like \\"
my $def = "default=((\"(\\\"|[^\"])*\")|null)";
my $res = "restart";
my $reg = "^(${def}\\s+${res}|(${def})?|${res}|${res}\\s+${def})\$";
unless ($opts =~ m!${reg}!) {
print STDERR "$file:$linenr:$col: error: Bad options \"$opts\", no match for m!${reg}!\n";
return -1;
}
return 0;
}
sub check_reference {
my ($col, $line, $linenr, $file) = @_;
my $opts = substr($line, $col);
my $def = "default=((\"(\\\"|[^\"])*\")|null)";
unless ($opts eq "" || $opts =~m!${def}!) {
print STDERR "$file:$linenr:$col: error: reference can only "
. "take the 'default' option\n";
return -1;
}
return 0;
}
sub check_enum {
my ($col, $line, $linenr, $file) = @_;
my $ret = ®_words_check($col, $line, $linenr, $file,
"^("
. "[{},]"
. "|[A-Z][A-Z0-9_]+,?"
. "|default=[A-Z][A-Z0-9_]+"
. "|restart"
. ")\$");
return -1 if $ret;
$col = index($line, '}', $col) + 1; #move $col to end of enum --> }
while (substr($line, $col, 1) =~ m=[\s\{]=) {
++$col;
}
return 0 if $col >= length($line);
return ®_words_check($col, $line, $linenr, $file,
"^("
. "default=[A-Z][A-Z0-9_]+"
. "|restart"
. ")\$");
}
sub check_bool {
my ($col, $line, $linenr, $file) = @_;
return ®_words_check($col, $line, $linenr, $file,
"^("
. "default=(true|false)"
. "|restart"
. ")\$");
}
sub check_properties {
my ($col, $line, $linenr, $file) = @_;
return ®_words_check($col, $line, $linenr, $file, "^restart\$");
}
sub check_import {
my ($col, $line, $linenr, $file) = @_;
my $word = "[a-zA-Z][_a-zA-Z0-9]*";
my $fnam = "${word}(\\.${word})*";
my $var = "${word}((\\[\\])?\.${word})*(\\[\\])?";
return ®_words_check($col, $line, $linenr, $file,
"^${fnam}\\.def:(${var})?\$");
return 0;
}
my $lines = &do_file($defname, "", "");
if ($lines == -1) {
die "There were irrecoverable errors in \"$defname\"!\n";
}
if ($lines == 0) {
die "$defname:1: error: Resulting definition is empty!\n";
}
exit 0;
© 2015 - 2025 Weber Informatics LLC | Privacy Policy