pa.configgen.6.274.30.source-code.make-config-preproc.pl Maven / Gradle / Ivy
#!/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