#!/usr/bin/env perl

# $Header: /cvs/G/EPICS/App/scripts/dbLoadTemplate,v 1.13 2018/07/05 14:54:40 zimoch Exp $

use strict;
use Getopt::Long;
use Data::Dumper;

my $show_lines;
my @include_dirs;
GetOptions ("L"    => \$show_lines,
            "I=s"  => \@include_dirs,
            "help|h|?" => \&help)
or die("Error in command line arguments\n");

sub help {
    printf "usage: dbLoadTemplate [options] substitutionfiles\n";
    printf "options: -? -h -help : show this help text\n";
    printf "         -I <dir>    : add include search dir\n";
    printf "         -L          : output '# file ...' and '# line ...' infos\n";
    exit;
}

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 = "";
our %subst;
our %global;

sub replace {
    my $macro = shift;
    my $default = shift;
    if (defined $subst{$macro}) { return $subst{$macro}; }
    if (defined $default) { 
        #print STDERR "$ARGV:$.:$macro default $default\n";
        return $default;
    }
    die "$ARGV:$.: macro \$($macro) undefined\n";
}

sub expand {
    #print STDERR "expand $_\n";
    m/\$\(([^)]*)$/ and die "$ARGV:$.: unterminated macro \$($1\n";
    %subst and s/\$\(([^=)]*)?(=([^)]*))?\)/replace $1,$3/ge; # replace macros
    $_;
}

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

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

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 "$ARGV:$.: parse error: found '$_' instead of $desc\n";
    }
    s/^$QUOTECHAR(.*)$QUOTECHAR$/$1/; # remove quotes around strings
    expand;
}

sub findFile {
    my $filename = shift;
    # print STDERR "findFile $filename\n";
    if (-e $filename) { return $filename; }
    foreach my $dir (@include_dirs) {
        my $path = "$dir/$filename";
        if (-e $path)  { return $path; }
    }
}

sub handleRecord;
sub handleAlias;

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

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

sub parseSubst {
    # print STDERR "parseSubst $ARGV:$.\n";
    eval { expect "file|global" };
    if ($@) {
        $@ =~ /end of file/ or die $@;
        return 0;
    }
    if ($_ eq "global") {
        expect "{";
        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";
            $global{$macro} = $_;
        } 
        return 1;
    }
    
    my $filename = expect "$STRING|$WORD file name";
    $filename = (findFile $filename or die "$ARGV:$.: template file $filename not found\n");
    eval { expect "{","pattern|{ 'pattern' or '{'" };
    if ($_ eq "{") {
        # old style substitution
        do {
            local %subst = %global;
            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): Don't forget to adjust var dbTemplateMaxVars\n";
            }
            eval {parseTemplate $filename} or die "$@$ARGV:$.: called from here\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): Don't forget to adjust var dbTemplateMaxVars\n";
        }
        while (1) {
            local %subst = %global;
            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:$.\n";
        };
    }
    return 1;
}

sub parseFiles {
    foreach (@_) {
        local *ARGV;
        local %global;
        local %subst;
        my $filename = findFile $_ or die "file $_ not found\n";
        @ARGV = $filename;
        if (peekToken =~ "file|global") {
            while (parseSubst) {};
        } else {
            parseTemplate;
        }
    }
}

sub printline {
    if (!$show_lines) { return; }
    my $line = shift;
    our $oldline;
    if ($line != $oldline+1) {
        my $d = $line - $oldline - 1;
        if ($d > 0 && $d < 3) {
            print substr("\n\n\n",1,$d);
        } else {
            print "# line $line\n"; 
        }
    }
    $oldline = $line;
}

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

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

parseFiles @ARGV