#!/usr/bin/env perl

# $Header: /cvs/G/EPICS/App/scripts/dbLoadTemplate,v 1.9 2013/11/13 09:33:12 zimoch Exp $

use strict;

my $QUOTECHAR = '"';
my $NOWORDCHAR = ",(){}=";

my $NOWORD=qr/[${NOWORDCHAR}${QUOTECHAR}]/;                # single non-word character
my $WORD=qr/[^\s${NOWORDCHAR}${QUOTECHAR}]+/;              # unquoted word
my $STRING=qr/(?:$QUOTECHAR((?:\\.|\\\n|.)*?)$QUOTECHAR)/; # quoted string
my $SUBST=qr/(\$\(.*?\)|[^\s${NOWORDCHAR}${QUOTECHAR}])+/; # unquoted word with $(macro) allowed

# nextToken returns the next input word, string, or char
# It skips comments and whitespace
# it dies at end of file or on unterminated string
our $input = "";

sub nextToken {
    my $flags = shift;
    while ($input =~ /^\s*(#|$)/) {
        $input = <ARGV>;
        if (!defined $input) {
            return if index ($flags, "e") >= $[;
            die "unexpected end of file in $ARGV\n";
        }
    }
    $input =~ s/^\s*($STRING|$SUBST|$WORD|$NOWORD)\s*(#.*\n?)?//;
    $1 ne $QUOTECHAR or die "unterminated string in $ARGV line $.\n";
    #print STDERR "nextToken from $ARGV line $. is $1\n";
    $1;
}

sub peekToken {
    my $token = nextToken;
    $input = "$token $input";
    $token;
}

our %subst;

sub replace {
    my $macro = shift;
    defined $subst{$macro} or die "macro \$($macro) undefined in $ARGV line $.\n";
    $subst{$macro};
}

sub expect {
    my ($desc, $success, $token);
    foreach my $want (@_) {
        $_ = nextToken;
        if (length $want == 1) { # single character
            $desc = "'$want'";
            $success = $_ eq $want;
        } else {
            (my $expr, $desc) = split / /, $want, 2;
            $desc = "'$expr'" if $desc eq "";
            $success = /^$expr$/;
        }
        $success or die "parse error in $ARGV line $.: found '$_' instead of $desc\n";
    }
    s/^$QUOTECHAR(.*)$QUOTECHAR$/$1/; # remove quotes around strings
    m/\$\(([^)]*)$/ and die "unterminated macro \$($1 in $ARGV line $.\n";
    %subst and s/\$\((.*?)\)/replace($1)/ge; # replace macros
    $_;
}

sub handleRecord;
sub handleAlias;

sub parseRecord {
    eval { expect "g?record|alias 'record' or 'grecord' or 'alias'" };
    # print STDERR "parseRecord $ARGV line $.\n";
    if ($@) {
        $@ =~ /end of file/ or die $@;
        return 0;
    }
    if ($_ eq "alias") {
        my $name = expect "(", "$STRING quoted record name";
        my $alias = expect ",", "$STRING quoted alias name";
        expect ")";
        handleAlias $name, $alias;
        return 1;
    }
    
    my $rtype = expect "(", "$WORD record type";
    my $name = expect ",", "$STRING quoted record name";
    expect ")", "{";
    my @fields;
    my @aliases;
    while (1) {
        expect "field|alias|} 'field or alias'";
        if ($_ eq "alias") {
            push @aliases, expect "(", "$STRING quoted alias name";
            expect ")";
            next;
        }
        last if $_ eq "}";
        push @fields, expect "(", "$WORD field name";
        push @fields, expect ",", "$STRING|$SUBST quoted field value";
        expect ")";
    } 
    handleRecord $rtype,$name,@fields;
    while (@aliases) {
        handleAlias $name, shift @aliases;
    }
    return 1;
}

sub parseTemplate {
    # print STDERR "parseTemplate @_\n";
    if (@_) {
        local *ARGV;
        local $input;
        @ARGV = @_;
        while (parseRecord) {};
    } else {
        while (parseRecord) {};
    }
    return 1;
}

sub parseSubst {
    # print STDERR "parseSubst $ARGV line $.\n";
    my $filename;
    eval { $filename = expect "file","$STRING|$WORD file name" };
    if ($@) {
        $@ =~ /end of file/ or die $@;
        return 0;
    }
    die "template file $filename not found in $ARGV line $.\n" unless -e $filename;
    die "template file $filename not readable in $ARGV line $.\n" unless -r $filename;
    eval { expect "{","pattern|{ 'pattern' or '{'" };
    if ($_ eq "{") {
        # old style substitution
        do {
            local %subst;
            while (1) {
                my $macro;
                $macro = expect "$WORD|,|} macro name";
                # one comma allowed
                if ($_ eq ",") {$macro = expect "$WORD|} macro name";}
                last if $_ eq '}';
                expect "=", "$STRING|$SUBST value for $macro";
                $subst{$macro} = $_;
            }
            my $n;
            $n = scalar (keys %subst);
            if ($n > 100) {
                print STDERR "Warning: more than 100 marcos ($n in your case) is not supported\n";
            }
            eval {parseTemplate $filename} or die "$@called from $ARGV line $.\n";
            expect "{|} '{' or '}'";
        } while $_ eq "{";
    } else {
        # pattern substitution
        expect "{";
        my @macros;
        while (1) {
            expect "$WORD|,|} macro name";
            # one comma allowed
            if ($_ eq ",") {expect "$WORD|} macro name";}
            last if $_ eq '}';
            push @macros, $_;
        };
        my $n;
        $n = scalar (@macros);
        if ($n > 100) {
            print STDERR "Warning: more than 100 marcos ($n in your case) is not supported\n";
        }
        while (1) {
            local %subst;
            expect "{|} '{' or '}'";
            last if $_ eq "}";
            foreach my $macro (@macros) {
                expect "$STRING|$SUBST|, value for $macro";
                if ($_ eq ",") {expect "$STRING|$SUBST value for $macro";}
                $subst{$macro} = $_;
            }
            expect "}";
            eval {parseTemplate $filename} or die "$@called from $ARGV line $.\n";
        };
    }
    return 1;
}

sub parseFiles {
    foreach (@_) {
        die "file $_ not found.\n" unless -e $_;
        die "file $_ not readable.\n" unless -r $_;
    }
    foreach (@_) {
        local *ARGV;
        local %subst;
        @ARGV = $_;
        if (peekToken eq "file") {
            while (parseSubst) {};
        } else {
            parseTemplate;
        }
    }
}

sub handleRecord {
    my $rtype = shift;
    my $rname = shift;
    print "record($rtype,\"$rname\") {";
    while (@_) {
        my $fieldname = shift;
        my $value = shift;
        print "\n\t\tfield($fieldname, \"$value\")";
    }
    print "}\n";
}

sub handleAlias {
    my $rname = shift;
    my $alias = shift;
    print "alias(\"$rname\",\"$alias\")\n";
}

parseFiles @ARGV